cl-tl-rpc/tl-rpc.lisp

;;; This file contains modified code from cl-m4 that demonstrates how graylex
;;; can be used. If you want a full-fledged example including recursive descent
;;; parsing, please checkout http://github.com/e-user/cl-m4

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

(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 strip-comments (input)
  (apply #'concatenate 'string
         (remove :comment
                 (substitute " " nil
                             (parse-string*
                              (many? (choices (<token>)
                                              (named-seq? (<- p (<punctuation>)) (string p))
                                              "---"
                                              (whitespace?)
                                              (named-seq? (<sl-comment>) :comment)
                                              (named-seq? (<ml-comment>) :comment)))
                              input)))))

;; Actual parser
(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?) #\_))

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

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

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

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

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

(defun <lc-ident-ns> ()
  (named-seq? (<- ns (opt? (seq-list? (<namespace-ident>) #\.)))
              (<- id (<lc-ident>))
              (concat (when ns (string-concat ns)) id)))

(defun <uc-ident-ns> ()
  (named-seq? (<- ns (opt? (seq-list? (<namespace-ident>) #\.)))
              (<- id (<uc-ident>))
              (concat (when ns (string-concat ns)) id)))

(defun <lc-ident-full> ()
  (named-seq? (<- id (<lc-ident-ns>))
              (<- name (opt? (seq-list? #\# (times? (<hex-digit>) 8))))
              (concat id (when name (coerce (apply #'cons name) 'string)))))

(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"))
   (whitespace?)
   (<- 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)))

(defun <tl-program> ()
  (named-seq? (<- hd (<constr-declarations>))
              (whitespace? :accept-empty t)
              (<- tl (many?
                      (choice
                       (mdo "---" "functions" "---"
                            (<fun-declarations>))
                       (mdo "---" "types" "---"
                            (<constr-declarations>)))))
              (cons hd tl)))