<commit_before>;;;
;;; owl cfg parsing combinators and macros
;;;

(define-library (owl parse)

   (export
      let-parses
      get-byte
      get-imm
      get-epsilon
      assert
      get-byte-if
      get-rune
      get-rune-if
      get-one-of
      get-word
      get-word-ci       ; placeholder
      get-either
      get-any-of
      get-kleene*
      get-kleene+
      get-greedy*
      get-greedy+
      try-parse         ; parser x ll x path|#false x errmsg|#false x fail-val
      peek
      fd->exp-stream
      file->exp-stream
      null-stream?)

   (import
      (owl defmac)
      (owl lazy)
      (owl math)
      (owl list)
      (owl string)
      (owl list-extra)
      (owl unicode)
      (owl eof)
      (owl io)
      (owl vector)
      (owl render)
      (only (owl primop) wait)
      (owl syscall))

   (begin
      ; (parser ll ok fail pos)
      ;      -> (ok ll' fail' val pos)
      ;      -> (fail fail-pos fail-msg')
      (define (null-stream? ll)
         (cond
            ((null? ll) #true)
            ((pair? ll) #false)
            (else (null-stream? (ll)))))

      (define eof-error "end of input")

      (define (get-byte ll ok fail pos)
         (cond
            ((null? ll) (fail pos eof-error)) ; will always be the largest value 
            ((pair? ll) (ok (cdr ll) fail (car ll) (+ pos 1)))
            (else (get-byte (ll) ok fail pos))))

      ; read nothing, succeed with val
      (define (get-epsilon val)
         (λ (ll ok fail pos)
            (ok ll fail val pos)))

      ;; todo: in addition to assert would be useful to have compute (returns the value) and check <predicate> 
      (define (assert pred val) ; fixme: should have a error message to throw when no luck
         (λ (ll ok fail pos)
            (let ((res (pred val)))
               (if res
                  (ok ll fail val pos)
                  (fail pos "parser assert blocked")))))

      (define-syntax let-parses
         (syntax-rules (verify eval)
            ((let-parses 42 sc ft lst pos ((val (eval term)) . r) body)
               (let ((val term))
                  (let-parses 42 sc ft lst pos r body)))
            ((let-parses 42 sc ft lst pos ((val parser) . r) body)
               (parser lst 
                  (λ (lst ft val pos)
                     (let-parses 42 sc ft lst pos r body))
                  ft pos))
            ((let-parses 42 sc ft lst pos () body) (sc lst ft body pos))
            ((let-parses 42 sc ft lst pos ((verify term msg) . r) body)
               (if term
                  (let-parses 42 sc ft lst pos r body)
                  (ft pos msg)))
            ((let-parses ((a . b) ...) body)
               (λ (ll ok fail pos)
                  (let-parses 42 ok fail ll pos ((a . b) ...) body)))))

      ;; testing a slower one to check assertions
      (define (get-byte-if pred)
         (let-parses
            ((b get-byte)
             (verify (pred b) "bad byte")
             ;(_ (assert pred b))
             )
            b))

      (define peek-mark "loltron")
      (define (peek-val? x) (if (pair? x) (eq? (car x) peek-mark) #false))

      ; make sure the next thing is *not* accepted by parser (unfortunate name, change later)
      (define (peek parser) ; fixme, add error message
         (λ (lst ok fail pos)
            (parser lst 
               (λ (lst fail val pos)
                  ; we do *not* want a match
                  (fail lst "peek matched"))
               (λ (fpos fmsg)
                  ; ok not to match
                  (ok lst fail 'peeked pos))
               pos)))

      (define (get-imm n)
         (let-parses
            ((a get-byte)
             (verify (eq? a n) '(expected n)))
            a))

      (define (get-one-of bytes)
         (get-byte-if (λ (x) (has? bytes x))))

      (define (get-word str val)
         (let ((bytes (string->bytes str)))
            (λ (lst ok fail pos)
               (let loop ((bytes bytes) (lst lst) (fail fail) (pos pos))
                  (if (null? bytes)
                     (ok lst fail val pos)
                     (get-byte lst
                        (λ (lst fail byte pos)
                           (if (eq? byte (car bytes))
                              (loop (cdr bytes) lst fail pos)
                              (fail pos (list "expected next '" (runes->string bytes) "'"))))
                        fail pos))))))
     
      ;; fixme: not correct yet
      (define (get-word-ci str val)
         (let ((bytes (string->bytes str)))
            (λ (lst ok fail pos)
               (let loop ((bytes bytes) (lst lst) (fail fail) (pos pos))
                  (if (null? bytes)
                     (ok lst fail val pos)
                     (get-byte lst
                        (λ (lst fail byte pos)
                           (if (char-ci=? byte (car bytes))
                              (loop (cdr bytes) lst fail pos)
                              (fail pos (list "expected next '" (runes->string bytes) "'"))))
                        fail pos))))))

      (define (get-either a b)
         (λ (lst ok fail pos)
            (a lst ok
               (λ (fa fai)
                  (b lst ok (λ (fb fbi) (if (< fa fb) (fail fb fbi) (fail fa fai))) pos))
               pos)))

      (define (get-kleene* par)
         (get-either
            (let-parses
               ((hd par) (tl (get-kleene* par)))
               (cons hd tl))
            (get-epsilon null)))

      ; get all of successful parses of parser not allowing backtracking
      ; intention being that "aaaaa" has quite a few combinations of (kleene+ a), 
      ; and when describing something like lexical structure, which is usually 
      ; handled by a pass greedily matching regular expressions, this may cause 
      ; unexpected exponential slowdowns on parse errors when using simple 
      ; parsing combinators like these in lib-parse.

      (define (get-greedy parser zero-ok?)
         (λ (lst ok fail pos)
            (let loop ((lst lst) (rvals null) (pos pos))
               (parser lst
                  (λ (lst fail val pos)
                     (loop lst (cons val rvals) pos))
                  (λ (fpos freason)
                     (if (or zero-ok? (pair? rvals))
                        (ok lst fail (reverse rvals) pos) ; pass the original failure cont
                        (fail fpos freason))) ; could fail differently when zero and requested at least one
                  pos))))

      (define (get-greedy* parser) (get-greedy parser #true))
      (define (get-greedy+ parser) (get-greedy parser #false))

      (define (get-kleene+ what)
         (let-parses
            ((hd what)
             (tl (get-kleene* what)))
            (cons hd tl)))

      (define-syntax get-any-of
         (syntax-rules ()<commit_msg>added greedy repeat<commit_after>;;;
;;; owl cfg parsing combinators and macros
;;;

(define-library (owl parse)

   (export
      let-parses
      get-byte
      get-imm
      get-epsilon
      assert
      get-byte-if
      get-rune
      get-rune-if
      get-one-of
      get-word
      get-word-ci       ; placeholder
      get-either
      get-any-of
      get-kleene*
      get-kleene+
      get-greedy*
      get-greedy+
      get-greedy-repeat
      try-parse         ; parser x ll x path|#false x errmsg|#false x fail-val
      peek
      fd->exp-stream
      file->exp-stream
      null-stream?)

   (import
      (owl defmac)
      (owl lazy)
      (owl math)
      (owl list)
      (owl string)
      (owl list-extra)
      (owl unicode)
      (owl eof)
      (owl io)
      (owl vector)
      (owl render)
      (only (owl primop) wait)
      (owl syscall))

   (begin
      ; (parser ll ok fail pos)
      ;      -> (ok ll' fail' val pos)
      ;      -> (fail fail-pos fail-msg')
      (define (null-stream? ll)
         (cond
            ((null? ll) #true)
            ((pair? ll) #false)
            (else (null-stream? (ll)))))

      (define eof-error "end of input")

      (define (get-byte ll ok fail pos)
         (cond
            ((null? ll) (fail pos eof-error)) ; will always be the largest value 
            ((pair? ll) (ok (cdr ll) fail (car ll) (+ pos 1)))
            (else (get-byte (ll) ok fail pos))))

      ; read nothing, succeed with val
      (define (get-epsilon val)
         (λ (ll ok fail pos)
            (ok ll fail val pos)))

      ;; todo: in addition to assert would be useful to have compute (returns the value) and check <predicate> 
      (define (assert pred val) ; fixme: should have a error message to throw when no luck
         (λ (ll ok fail pos)
            (let ((res (pred val)))
               (if res
                  (ok ll fail val pos)
                  (fail pos "parser assert blocked")))))

      (define-syntax let-parses
         (syntax-rules (verify eval)
            ((let-parses 42 sc ft lst pos ((val (eval term)) . r) body)
               (let ((val term))
                  (let-parses 42 sc ft lst pos r body)))
            ((let-parses 42 sc ft lst pos ((val parser) . r) body)
               (parser lst 
                  (λ (lst ft val pos)
                     (let-parses 42 sc ft lst pos r body))
                  ft pos))
            ((let-parses 42 sc ft lst pos () body) (sc lst ft body pos))
            ((let-parses 42 sc ft lst pos ((verify term msg) . r) body)
               (if term
                  (let-parses 42 sc ft lst pos r body)
                  (ft pos msg)))
            ((let-parses ((a . b) ...) body)
               (λ (ll ok fail pos)
                  (let-parses 42 ok fail ll pos ((a . b) ...) body)))))

      ;; testing a slower one to check assertions
      (define (get-byte-if pred)
         (let-parses
            ((b get-byte)
             (verify (pred b) "bad byte")
             ;(_ (assert pred b))
             )
            b))

      (define peek-mark "loltron")
      (define (peek-val? x) (if (pair? x) (eq? (car x) peek-mark) #false))

      ; make sure the next thing is *not* accepted by parser (unfortunate name, change later)
      (define (peek parser) ; fixme, add error message
         (λ (lst ok fail pos)
            (parser lst 
               (λ (lst fail val pos)
                  ; we do *not* want a match
                  (fail lst "peek matched"))
               (λ (fpos fmsg)
                  ; ok not to match
                  (ok lst fail 'peeked pos))
               pos)))

      (define (get-imm n)
         (let-parses
            ((a get-byte)
             (verify (eq? a n) '(expected n)))
            a))

      (define (get-one-of bytes)
         (get-byte-if (λ (x) (has? bytes x))))

      (define (get-word str val)
         (let ((bytes (string->bytes str)))
            (λ (lst ok fail pos)
               (let loop ((bytes bytes) (lst lst) (fail fail) (pos pos))
                  (if (null? bytes)
                     (ok lst fail val pos)
                     (get-byte lst
                        (λ (lst fail byte pos)
                           (if (eq? byte (car bytes))
                              (loop (cdr bytes) lst fail pos)
                              (fail pos (list "expected next '" (runes->string bytes) "'"))))
                        fail pos))))))
     
      ;; fixme: not correct yet
      (define (get-word-ci str val)
         (let ((bytes (string->bytes str)))
            (λ (lst ok fail pos)
               (let loop ((bytes bytes) (lst lst) (fail fail) (pos pos))
                  (if (null? bytes)
                     (ok lst fail val pos)
                     (get-byte lst
                        (λ (lst fail byte pos)
                           (if (char-ci=? byte (car bytes))
                              (loop (cdr bytes) lst fail pos)
                              (fail pos (list "expected next '" (runes->string bytes) "'"))))
                        fail pos))))))

      (define (get-either a b)
         (λ (lst ok fail pos)
            (a lst ok
               (λ (fa fai)
                  (b lst ok (λ (fb fbi) (if (< fa fb) (fail fb fbi) (fail fa fai))) pos))
               pos)))

      (define (get-kleene* par)
         (get-either
            (let-parses
               ((hd par) (tl (get-kleene* par)))
               (cons hd tl))
            (get-epsilon null)))

      ; get all of successful parses of parser not allowing backtracking
      ; intention being that "aaaaa" has quite a few combinations of (kleene+ a), 
      ; and when describing something like lexical structure, which is usually 
      ; handled by a pass greedily matching regular expressions, this may cause 
      ; unexpected exponential slowdowns on parse errors when using simple 
      ; parsing combinators like these in lib-parse.

      (define (get-greedy parser zero-ok?)
         (λ (lst ok fail pos)
            (let loop ((lst lst) (rvals null) (pos pos))
               (parser lst
                  (λ (lst fail val pos)
                     (loop lst (cons val rvals) pos))
                  (λ (fpos freason)
                     (if (or zero-ok? (pair? rvals))
                        (ok lst fail (reverse rvals) pos) ; pass the original failure cont
                        (fail fpos freason))) ; could fail differently when zero and requested at least one
                  pos))))

      (define (get-greedy* parser) (get-greedy parser #true))
      (define (get-greedy+ parser) (get-greedy parser #false))

      (define (get-greedy-repeat n parser)
         (λ (lst ok fail pos)
            (let loop ((lst lst) (rvals null) (pos pos) (n n))
               (if (eq? n 0)
                  (ok lst fail (reverse rvals) pos)
                  (parser lst
                     (λ (lst fail val pos)
                        (loop lst (cons val rvals) pos (- n 1)))
                     fail pos)))))

      (define (get-kleene+ what)
         (let-parses
            ((hd what)
             (tl (get-kleene* what)))
            (cons hd tl)))

      (define-syntax get-any-of
         (syntax-rules ()
{'fraction_non_alphanumeric': 0.11338223773235524, 'fraction_numerical': 0.002563919948721601, 'mean_word_length': 1.3198414009582025, 'pattern_counts': {'":': 0, '<': 7, '<?xml version=': 0, '>': 21, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 6, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '3163697', 'n_tokens_mistral': 4266, 'n_tokens_neox': 4020, 'n_words': 1541}