cl-tl-rpc/tl-rpc.lisp

(defpackage tl-rpc
  (:use :cl :parser-combinators :alexandria))
(in-package :tl-rpc)

(defun not-equal (a b)
  (not (equal a b)))

(defun <ml-not-end> ()
  (named-seq? (<- char
                  (choice (sat (curry #'not-equal #\*))
                          (except? #\* "*/")))
              (string char)))

(defun <ml-content> (ml-comment)
  (named-seq? (<- content
                  (many? (choice (named-seq? (<- inner ml-comment)
                                             (concatenate 'string "/*" inner "*/"))
                                 (<ml-not-end>))))
              (apply #'concatenate 'string content)))

(defun <ml-comment> ()
  (named? ml-comment
    (bracket? "/*" (<ml-content> ml-comment) "*/")))

(defun <sl-comment> ()
  (bracket? "//"
            (named-seq? (<- comment (many? (sat (curry #'not-equal #\Newline))))
                        (coerce comment 'string))
            #\Newline))

(defun <punctuation> ()
  (sat (rcurry #'member '(#\; #\( #\) #\{ #\} #\. #\# #\: #\[ #\] #\= #\? #\% #\+ #\< #\> #\, #\* #\!))))

(defun <token> ()
  (choice
   (between? (sat #'(lambda (i) (or (alphanumericp i)
                                    (member i '(#\_))))) 1 nil 'string)
   (quoted? :quote-char #\`)))

(defun tokenize (input)
  (remove :whitespace
          (parse-string*
           (many? (choices (<token>)
                           (<punctuation>)
                           (chook? :whitespace
                                   (choices (whitespace?) "---" (<sl-comment>) (<ml-comment>)))))
           input)))

;; Actual parsers
(defun <hex-digit> ()
  (choice (digit?) (sat (rcurry #'member '(#\a #\b #\c #\d #\e #\f)))))

(defun <letter> ()
  (choice (lower?) (upper?)))

(defun <ident-char> ()
  (choices (<letter>) (digit?) #\_))


(defmacro def-string-parser (name arguments &body body)
  (with-unique-names (inp)
    (multiple-value-bind (forms declarations docstring) (parse-body body :documentation t)
      `(defun ,name ,arguments
         ,docstring
         ,@declarations
         (sat (lambda (,inp)
                (and (stringp ,inp)
                     (parse-string* ,@forms ,inp :complete t))))))))

(defun concat (&rest args)
  (apply #'concatenate 'string args))

(defun string-concat (args)
  (apply #'concatenate 'string (mapcar 'string args)))

(def-string-parser <lc-ident> ()
  (named-seq? (<- hd (lower?))
              (<- tl (many? (<ident-char>)))
              (coerce (cons hd tl) 'string)))

(def-string-parser <uc-ident> ()
  (named-seq? (<- hd (upper?))
              (<- tl (many? (<ident-char>)))
              (coerce (cons hd tl) 'string)))

(def-string-parser <hex-string> (&optional len)
  (between? (<hex-digit>) len len))

(defun <namespace-ident> () (<lc-ident>))

(defstruct ident ns id name)

(defun <lc-ident-ns> ()
  (named-seq? (<- ns (opt? (seq-list? (<namespace-ident>) #\.)))
              (<- id (<lc-ident>))
              (make-ident :ns (car ns) :id id)))

(defun <uc-ident-ns> ()
  (named-seq? (<- ns (opt? (seq-list? (<namespace-ident>) #\.)))
              (<- id (<uc-ident>))
              (make-ident :ns (car ns) :id id)))

(defun <lc-ident-full> ()
  (named-seq? (<- id (<lc-ident-ns>))
              (<- name (opt? (seq-list? #\# (<hex-string> 8))))
              (progn (when name (setf (ident-name id) (second name)))
                     id)))

(defun <nat-const> ()
  (many1? (digit?)))

(defun <boxed-type-ident> () (<uc-ident-ns>))

(defun sep? (&optional accept-empty) (whitespace? :accept-empty accept-empty))

(defun <full-combinator-id> ()
  (choice (<lc-ident-full>) "_"))

(defun <combinator-id> ()
  (choice (<lc-ident-ns>) "_"))

(defun <type-ident> ()
  (choices
   (<boxed-type-ident>)
   (<lc-ident-ns>)
   "#"))

(defun <var-ident> ()
  (choice (<lc-ident>) (<uc-ident>)))

(defun <term> (expr)
  (named? term
    (choices
     (seq-list? "(" expr ")")
     (<type-ident>)
     (<var-ident>)
     (<nat-const>)
     (seq-list? "%" term)
     (seq-list? (<type-ident>) "<" (sepby1? expr ",") ">")
     )))

(defun <subexpr> (expr)
  (named? subexpr
    (choices
     (<term> expr)
     (seq-list? (<nat-const>) "+" subexpr)
     (seq-list? subexpr "+" (<nat-const>)))))

(defun <expr> ()
  (named? expr
    (many? (<subexpr> expr))))

(defun <type-expr> () (<expr>))
(defun <nat-expr> () (<expr>))
(defun <type-term> () (<term> (<expr>)))
(defun <nat-term> () (<term> (<expr>)))

(defun <opt-args> ()
  (named-seq?
   "{" (sep? t)
   (<- vars (sepby1? (<var-ident>) (sep?))) (sep? t)
   ":"
   (opt? "!")
   (<- type-expr (<type-expr>)) (sep? t)
   "}" (sep? t)
   (list :opt-args vars type-expr)))

(defun <multiplicity> () (<nat-term>))
(defun <var-ident-opt> () (choices (<var-ident>) "_"))
(defun <conditional-def> ()
  (seq-list? (<var-ident>) (opt? (seq-list? "." (<nat-const>))) "?"))

(defun <args> ()
  (named? args
    (choices
     (seq-list? (<var-ident-opt>) ":" (opt? (<conditional-def>)) (opt? "!") (<type-term>))
     (seq-list? (opt? (seq-list? (<var-ident-opt>) ":"))
                (opt? (seq-list? (<multiplicity>) "*"))
                "[" (many? args) "]")
     (seq-list? "(" (many1? (<var-ident-opt>)) ":" (opt? "!") (<type-term>) ")")
     (seq-list? (opt? "!") (<type-term>)))))

(defun <result-type> ()
  (choices
   (seq-list? (<boxed-type-ident>) (many? (<subexpr> (<expr>))))
   (seq-list? (<boxed-type-ident>) "<" (sepby1? (<subexpr> (<expr>)) ",") ">")))

(defun <combinator-decl> ()
  (named-seq?
   (<- comb (<full-combinator-id>)) (sep?)
   (<- opt-args (many? (<opt-args>))) (sep? t)
   (<- args (many? (<args>))) (sep? t)
   "=" (sep?)
   (<- result-type (<result-type>)) (sep? t)
   ";"
   (list :comb-decl comb opt-args args result-type)))

(defun <partial-type-app-decl> ()
  (choices
   (named-seq?
    (<- type (<boxed-type-ident>)) (sep?)
    (<- ex (many1? (<subexpr> (<expr>)))) (sep?)
    ";"
    (list :part-type type ex))
   (named-seq?
    (<- type (<boxed-type-ident>)) (sep?)
    "<" (<- ex (sepby1? (<expr>) ",")) ">"
    (list :part-type type ex))))

(defun <partial-comb-app-decl> ()
  (seq-list? (<combinator-id>) (many1? (<subexpr> (<expr>)))))

(defun <partial-app-decl> ()
  (choices
   (<partial-type-app-decl>)
   (<partial-comb-app-decl>)))

(defun <builtin-combinator-decl> ()
  (named-seq?
   (<- comb (<full-combinator-id>)) (sep?)
   "?" (sep?)
   "=" (sep?)
   (<- type (<boxed-type-ident>)) (sep? t)
   ";"
   (list :builtin-decl comb type)))

(defun <final-decl> ()
  (named-seq?
   (<- type (choices "New" "Final" "Empty"))
   (<- ind (<boxed-type-ident>)) #\;
   (list :final-decl type ind)))

(defun <declaration> ()
  (choices (<builtin-combinator-decl>)
           (<combinator-decl>)
           (<partial-app-decl>)
           (<final-decl>)))

(defun <constr-declarations> ()
  (many? (named-seq? (<- dec (<declaration>)) #\; dec)))

(defun <fun-declarations> ()
  (many? (named-seq? (<- dec (<declaration>)) #\; dec)))

(defstruct tl-program constructors functions)
(defun <tl-program> ()
  (named-seq? (<- hd (<constr-declarations>))
              (<- tl (many?
                      (choice
                       (named-seq? "---" "functions" "---"
                                   (<- decs (<fun-declarations>))
                                   (cons :funcs decs))
                       (named-seq? "---" "types" "---"
                                   (<- decs (<constr-declarations>))
                                   (cons :constrs decs)))))
              (make-tl-program
               :constructors (append hd (mapcar #'cdr (remove :funcs tl :key #'car)))
               :functions (mapcar #'cdr (remove :constrs tl :key #'car)))))