Commits

Moritz Heidkamp  committed b76d6c5

Type annotations for most combinators

  • Participants
  • Parent commits be5b0a0
  • Branches typed

Comments (0)

Files changed (2)

File comparse.scm

 
 (use data-structures lazy-seq srfi-1 srfi-14 srfi-69 extras latch trie)
 
+(define-type input
+  (struct lazy-seq))
+
+(define-type parse
+  (or (pair * input) boolean))
+
+(define-type parser
+  (input -> parse))
+
+(define-type variadic-parser-combinator
+  ((or (list-of parser) parser) #!rest parser --> parser))
+
+;; (: result
+;;    (forall (value)
+;;            (value --> (input -> (pair value input)))))
+(: result (* -> parser))
 (define ((result value) input)
   (cons value input))
 
        (cons (lazy-head input)
              (lazy-tail input))))
 
+(: bind (parser (* -> parser) --> parser))
 (define ((bind parser proc) input)
   (and-let* ((value (parser input)))
     ((proc (car value)) (cdr value))))
 
+(: satisfies ((* #!rest * -> boolean) #!rest * --> parser))
 (define (satisfies condition . args)
   (bind item (lambda (x)
                (if (apply condition x args)
                    (result x)
                    fail))))
 
-(define (args-list parser more-parsers)
-  (if (and (list? parser) (null? more-parsers))
-      parser
-      (cons parser more-parsers)))
 
+(: arg-list (* (list-of *) --> (list-of *)))
+(define (arg-list arg more-args)
+  (if (and (list? arg) (null? more-args))
+      arg
+      (cons arg more-args)))
+
+(: parser-list (parser (list-of parser) --> (list-of parser)))
+(define parser-list arg-list)
+
+(: in (* #!rest * --> parser))
 (define (in collection . items)
   (if (and (null? items) (char-set? collection))
       (satisfies
        (lambda (c)
          (and (char? c)
               (char-set-contains? collection c))))
-      (satisfies memq (args-list collection items))))
+      (satisfies memq (arg-list collection items))))
 
 (define (is x)
   (satisfies eq? x))
            (lambda (binding)
              (sequence* (more-bindings ...) body ...))))))
 
+(: sequence variadic-parser-combinator)
 (define (sequence parser . parsers)
-  (let ((parsers (args-list parser parsers)))
+  (let ((parsers (parser-list parser parsers)))
     (lambda (input)
       (let loop ((parsers parsers)
                  (parts '())
                     (cons (car value) parts)
                     (cdr value))))))))
 
+(: char-seq (string -> parser))
 (define ((char-seq str) input)
   (let ((len (string-length str)))
     (let loop ((pos 0) (input input))
                (eq? (lazy-head input) (string-ref str pos))
                (loop (+ pos 1) (lazy-tail input)))))))
 
-;; Allow (any-of (list parser ...)) alternatively?
+(: any-of variadic-parser-combinator)
 (define ((any-of parser . parsers) input)
-  (let loop ((parsers (args-list parser parsers)))
+  (let loop ((parsers (parser-list parser parsers)))
     (and (not (null? parsers))
          (or ((car parsers) input)
              (loop (cdr parsers))))))
 
+(: all-of variadic-parser-combinator)
 (define ((all-of parser . parsers) input)
-  (let loop ((parsers (args-list parser parsers)))
+  (let loop ((parsers (parser-list parser parsers)))
     (and-let* ((value ((car parsers) input)))
       (if (null? (cdr parsers))
           value
           (and value (loop (cdr parsers)))))))
 
+(: none-of variadic-parser-combinator)
 (define ((none-of parser . parsers) input)
-  (let loop ((parsers (args-list parser parsers)))
+  (let loop ((parsers (parser-list parser parsers)))
     (if (null? parsers)
         (cons #t input)
         (and (not ((car parsers) input))
              (loop (cdr parsers))))))
 
+(: preceded-by variadic-parser-combinator)
 (define (preceded-by parser . parsers)
-  (let loop ((parsers (args-list parser parsers)))
+  (let loop ((parsers (parser-list parser parsers)))
     (bind (car parsers)
           (lambda (value)
             (if (null? (cdr parsers))
                 (result value)
                 (loop (cdr parsers)))))))
 
+(: none-of* (parser parser #!rest parser -> parser))
 (define (none-of* parser but . parsers)
   (receive (but parsers) (car+cdr (reverse (cons* parser but parsers)))
     (preceded-by (none-of parsers) but)))
 
+(: followed-by variadic-parser-combinator)
 (define ((followed-by parser following . more-following) input)
   (and-let* ((value (parser input)))
-    (let loop ((following (args-list following more-following))
+    (let loop ((following (parser-list following more-following))
                (input (cdr value)))
       (if (null? following)
           value
           (and-let* ((value ((car following) input)))
             (loop (cdr following) (cdr value)))))))
 
+(: enclosed-by (parser parser parser --> parser))
 (define (enclosed-by open content close)
   (sequence* ((_ open) (value content) (_ close))
     (result value)))
 
 (define (->parser object)
   (cond ((procedure? object) object)
-        ((char-set? object) (satisfies object))
+        ((char-set? object) (in object))
         ((char? object) (is object))
         ((string? object) (char-seq object))
         (else (error "Don't know how to turn object into parser" object))))
 
+(: zero-or-more (parser --> parser))
 (define (zero-or-more parser)
   (any-of (sequence* ((x parser)
                       (xs (zero-or-more parser)))
             (result (cons x xs)))
           (result '())))
 
+(: one-or-more (parser --> parser))
 (define (one-or-more parser)
   (sequence* ((x parser)
               (y (zero-or-more parser)))
     (result (cons x y))))
 
+(: repeated-until (parser parser --> parser))
 (define (repeated-until parser end)
   (any-of (all-of end (result '()))
           (sequence* ((x parser)
                       (y (repeated-until parser end)))
             (result (cons x y)))))
 
+(: repeated* (parser fixnum (or boolean fixnum) --> parser))
 (define (repeated* parser min max)
   (any-of (sequence* ((x parser)
                       (y (repeated* parser
               (result '())
               fail)))
 
+(: repeated (parser #!rest * --> parser))
 (define (repeated parser #!key (min 0) max until)
   (if until
       (cond (max
                (result (append x y)))))
       (repeated* parser min max)))
 
+(: maybe (parser --> parser))
 (define (maybe parser)
   (any-of parser (result #f)))
 
+(: as-string (parser --> parser))
 (define (as-string parser)
   (sequence* ((parts parser))
     (result (apply conc (remove boolean? (flatten parts))))))
 (define memo-table
   (make-parameter #f))
 
+(: lazy-seq-prefix (input input -> (or null list)))
 (define (lazy-seq-prefix from to)
   (let loop ((from from))
     (if (or (eq? from to) (lazy-null? from))
         (cons (lazy-head from)
               (loop (lazy-tail from))))))
 
+(: parser-memo-ref ((struct trie) input -> (or boolean (pair * fixnum))))
 (define (parser-memo-ref memo input)
   (let loop ((memo memo)
              (input input)
                (loop memo (lazy-tail input) (+ 1 length))
                (cons (car value) length))))))
 
+(: memo-ref (parser input -> parse))
 (define (memo-ref parser input)
   (and-let* ((parser-memo (hash-table-ref/default (memo-table) parser #f))
              (result (parser-memo-ref parser-memo input)))
                 input
                 (loop (- n 1) (lazy-tail input)))))))
 
+(: memo-set! (parser input -> parse))
 (define (memo-set! parser input)
   (and-let* ((result (parser input)))
     (hash-table-update! (memo-table)
                         make-trie)
     result))
 
+(: memoize (parser -> parser))
 (define ((memoize parser) input)
   (if (memo-table)
       (or (memo-ref parser input)
         ((input-port? x) (input-port->lazy-seq x read-char))
         (else (error "Don't know how to turn object into lazy-seq" x))))
 
+(: parse (parser input #!rest * -> * input))
 (define (parse parser input #!key memoize)
   (parameterize ((memo-table (if memoize (make-hash-table) (memo-table))))
     (let* ((input (->lazy-seq input))

File comparse.setup

-(compile -d0 -O3 -J -s "comparse.scm")
+(compile -strict-types -emit-type-file comparse.types -d0 -O3 -J -s "comparse.scm")
 (compile -d0 -O3 -s "comparse.import.scm")
 
 (install-extension
  'comparse
- '("comparse.so" "comparse.import.so")
+ '("comparse.so" "comparse.import.so" "comparse.types")
  '((version "0.0.1")))