wip

tl-rpc.lisp

@@ -58,47 +58,61 @@
 
 
 (defmacro def-string-parser (name arguments &body body)
-  (with-unique-names (inp)
+  (with-unique-names (inp res peek)
     (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))))))))
+         #'(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))))))))))
 
-(defun concat (&rest args)
-  (apply #'concatenate 'string args))
-
-(defun string-concat (args)
-  (apply #'concatenate 'string (mapcar 'string args)))
+(defstruct ident ns id name)
 
 (def-string-parser <lc-ident> ()
   (named-seq? (<- hd (lower?))
               (<- tl (many? (<ident-char>)))
-              (coerce (cons hd tl) 'string)))
+              (make-ident :id (coerce (cons hd tl) 'string))))
 
 (def-string-parser <uc-ident> ()
   (named-seq? (<- hd (upper?))
               (<- tl (many? (<ident-char>)))
-              (coerce (cons hd tl) 'string)))
+              (make-ident :id (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 <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>))
-              (make-ident :ns (car ns) :id id)))
+              (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>))
-              (make-ident :ns (car ns) :id id)))
+              (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>))
@@ -106,45 +120,52 @@
               (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>)
-   "#"))
+   (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? #\( expr #\))
+     (seq-list? (<type-ident>) #\< (sepby1? expr #\,) #\>)
      (<type-ident>)
      (<var-ident>)
      (<nat-const>)
-     (seq-list? "%" term)
-     (seq-list? (<type-ident>) "<" (sepby1? expr ",") ">")
-     )))
+     (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
-     (<term> expr)
-     (seq-list? (<nat-const>) "+" subexpr)
-     (seq-list? subexpr "+" (<nat-const>)))))
+     (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
@@ -155,56 +176,62 @@
 (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?
-   "{" (sep? t)
-   (<- vars (sepby1? (<var-ident>) (sep?))) (sep? t)
-   ":"
-   (opt? "!")
-   (<- type-expr (<type-expr>)) (sep? t)
-   "}" (sep? t)
-   (list :opt-args vars type-expr)))
+   #\{
+   (<- 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 <var-ident-opt> () (choices (<var-ident>) #\_))
 (defun <conditional-def> ()
-  (seq-list? (<var-ident>) (opt? (seq-list? "." (<nat-const>))) "?"))
+  (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>)))))
+     (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>)) ",") ">")))
+   (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)
-   ";"
+   (<- 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>)) (sep?)
-    (<- ex (many1? (<subexpr> (<expr>)))) (sep?)
-    ";"
+    (<- type (<boxed-type-ident>))
+    (<- ex (many1? (<subexpr> (<expr>))))
+    #\;
     (list :part-type type ex))
    (named-seq?
-    (<- type (<boxed-type-ident>)) (sep?)
-    "<" (<- ex (sepby1? (<expr>) ",")) ">"
+    (<- type (<boxed-type-ident>))
+    #\< (<- ex (sepby1? (<expr>) #\,)) #\>
     (list :part-type type ex))))
 
 (defun <partial-comb-app-decl> ()
@@ -217,17 +244,17 @@
 
 (defun <builtin-combinator-decl> ()
   (named-seq?
-   (<- comb (<full-combinator-id>)) (sep?)
-   "?" (sep?)
-   "=" (sep?)
-   (<- type (<boxed-type-ident>)) (sep? t)
-   ";"
+   (<- 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>)) #\;
+   (<- ind (<boxed-type-ident>))
+   #\;
    (list :final-decl type ind)))
 
 (defun <declaration> ()
@@ -237,10 +264,10 @@
            (<final-decl>)))
 
 (defun <constr-declarations> ()
-  (many? (named-seq? (<- dec (<declaration>)) #\; dec)))
+  (many? (<declaration>)))
 
 (defun <fun-declarations> ()
-  (many? (named-seq? (<- dec (<declaration>)) #\; dec)))
+  (many? (<declaration>)))
 
 (defstruct tl-program constructors functions)
 (defun <tl-program> ()