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
          (substitute #\_ "_"
                      (parse-string*
                       (many? (choices (<token>)
                                       (<punctuation>)
                                       (chook? :whitespace
                                               (choices (whitespace?) "---"
                                                        (<sl-comment>) (<ml-comment>)))))
                       input)
                      :test #'equal)))

;; 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 res peek)
    (multiple-value-bind (forms declarations docstring) (parse-body body :documentation t)
      `(defun ,name ,arguments
         ,docstring
         ,@declarations
         #'(lambda (,inp)
             (typecase ,inp
               (parser-combinators::end-context (constantly nil))
               (parser-combinators::context
                (let* ((,peek (parser-combinators::context-peek ,inp))
                       (,res (and (stringp ,peek)
                                  (parse-string* ,@forms ,peek :complete t))))
                  (if ,res
                      (let ((closure-value
                             (make-instance 'parser-possibility
                                            :tree ,res :suffix (parser-combinators::context-next ,inp))))
                        #'(lambda ()
                            (when closure-value
                              (prog1
                                  closure-value
                                (setf closure-value nil)))))
                      (constantly nil))))))))))

(defstruct ident ns id name)

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

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

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

(defun <namespace-ident> ()
  (named-seq? (<- ns (<lc-ident>))
              (make-ident :ns (ident-id ns))))

(defun <lc-ident-ns> ()
  (named-seq? (<- ns (opt? (seq-list? (<namespace-ident>) #\.)))
              (<- id (<lc-ident>))
              (let ((ident (if ns (car ns) id)))
                (when ns (setf (ident-id ident) (ident-id id)))
                ident)))

(defun <uc-ident-ns> ()
  (named-seq? (<- ns (opt? (seq-list? (<namespace-ident>) #\.)))
              (<- id (<uc-ident>))
              (let ((ident (if ns (car ns) id)))
                (when ns (setf (ident-id ident) (ident-id id)))
                ident)))

(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 <boxed-type-ident> () (<uc-ident-ns>))

(defun <type-ident> ()
  (choices
   (<boxed-type-ident>)
   (<lc-ident-ns>)
   (named-seq? #\# (make-ident :id "nat"))))

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

(def-string-parser <nat-const> ()
  (named-seq? (<- digits (many1? (digit?)))
              (parse-integer (coerce digits 'string))))

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

(defun <subexpr1> ()
  (named? subexpr1
    (opt? (named-seq? #\+
                      (<- hd (<nat-const>))
                      (<- tl subexpr1)
                      (append (list #\+ hd) (cdr tl))))))

(defun <subexpr> (expr)
  (named? subexpr
    (choices
     (named-seq? (<- hd (<nat-const>))
                 #\+
                 (<- tl subexpr)
                 (<- sub (<subexpr1>))
                 (append (list #\+ hd)
                         (list tl)
                         (cdr sub)))
     (named-seq? (<- term (<term> expr))
                 (<- sub (<subexpr1>))
                 (if sub (append (list #\+ term) (cdr sub))
                     term)))))

(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 <full-combinator-id> ()
  (choice (<lc-ident-full>) #\_))

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

(defun <opt-args> ()
  (named-seq?
   #\{
   (<- vars (many1? (<var-ident>)))
   #\:
   (<- excl (opt? #\!))
   (<- type-expr (<type-expr>))
   #\}
   (list :opt-args vars excl 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>))
   (<- opt-args (many? (<opt-args>)))
   (<- args (many? (<args>)))
   #\=
   (<- result-type (<result-type>))
   #\;
   (list :comb-decl comb opt-args args result-type)))

(defun <partial-type-app-decl> ()
  (choices
   (named-seq?
    (<- type (<boxed-type-ident>))
    (<- ex (many1? (<subexpr> (<expr>))))
    #\;
    (list :part-type type ex))
   (named-seq?
    (<- type (<boxed-type-ident>))
    #\< (<- 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>))
   #\? #\=
   (<- type (<boxed-type-ident>))
   #\;
   (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? (<declaration>)))

(defun <fun-declarations> ()
  (many? (<declaration>)))

(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)))))