peg in scheme

monadic-peg.scm

(import (scheme base)
        (scheme write)
        (gauche partcont))

(define-syntax PEG:reify
  (syntax-rules ()
    ((_ expr)
     (reset (PEG:unit expr)))))

(define (PEG:reflect x)
  (shift k (PEG:bind x k)))

;;; type Parser i r = i -> Maybe (r, i)

(define (PEG:bind m f)
  (lambda (i)
    (let ((x (m i)))
      (and x ((f (car x)) (cdr x))))))

(define (PEG:unit x)
  (lambda (i)
    `(,x . ,i)))

(define (PEG:map f p)
  (PEG:reify
   (let ((x (PEG:reflect p)))
     (f x))))

(define PEG:zero
  (lambda (i) #f))

(define (PEG:plus a b)
  (lambda (i)
    (or (a i) (b i))))


;;; PEG

(define (PEG:not a)
  (lambda (i)
    (and (not (a i)) `(#f . ,i))))

(define (PEG:and a)
  (lambda (i)
    (and (a i) `(#f . ,i))))

(define-syntax PEG:lazy
  (syntax-rules ()
    ((_ expr)
     (lambda (i) (expr i)))))


;;; aux

(define (PEG:choice . xs)
  (if (null? xs)
      PEG:zero
      (PEG:plus (car xs) (apply PEG:choice (cdr xs)))))

(define (PEG:optional a)
  (PEG:choice a (PEG:unit #f)))

(define (PEG:many a)
  (PEG:lazy
   (PEG:choice
    (PEG:reify
     (let* ((a (PEG:reflect a))
            (b (PEG:reflect (PEG:many a))))
       (cons a b)))
    PEG:null)))


;;; string stream parser

(define input #f)

(define (set-input! str)
  (set! input str))

(define (PEG:string str)
  (lambda (i)
    (let ((j (min (+ i (string-length str)) (string-length input))))
      (and (equal? str (string-copy input i j))
           `(,str . ,j)))))

(define PEG:any
  (lambda (i)
    (and (< i (string-length input))
         `(,(string-ref input i) . ,(+ i 1)))))

(define PEG:eof
  (PEG:not PEG:any))

(define (parse-string rule input)
  (set-input! input)
  (rule 0))


;;; test case

(define LPAREN (PEG:string "("))
(define RPAREN (PEG:string ")"))

(define PLUS (PEG:string "+"))
(define MINUS (PEG:string "-"))

(define ONE (PEG:map (lambda (_) 1) (PEG:string "1")))

(define S (PEG:lazy
           (PEG:reify (let* ((a (PEG:reflect A))
                            (_ (PEG:reflect PEG:eof)))
                        a))))

(define A (PEG:lazy
           (PEG:choice
            (PEG:reify (let* ((p (PEG:reflect P))
                              (_ (PEG:reflect PLUS))
                              (a (PEG:reflect A)))
                         (list '+ p a)))
            (PEG:reify (let* ((p (PEG:reflect P))
                              (_ (PEG:reflect MINUS))
                              (a (PEG:reflect A)))
                         (list '- p a)))
            P)))

(define P (PEG:lazy
           (PEG:choice
            (PEG:reify (let* ((_ (PEG:reflect LPAREN))
                              (a (PEG:reflect A))
                              (_ (PEG:reflect RPAREN)))
                         a))
            ONE)))

;(write (parse-string S "(((((((((((((1)))))))))))))"))
;(newline)


;;; in applicative style

(define (PEG:apply f . args)            ; synonym for <$>
  (PEG:reify
   (let loop ((args args) (ps '()))
     (if (null? args)
         (apply f (reverse ps))
         (loop (cdr args) (cons (PEG:reflect (car args)) ps))))))

(define (PEG:between l x r)
  (PEG:apply (lambda (_ x _) x) l x r))

(define (PEG:end x)
  (PEG:apply (lambda (x _) x) x PEG:eof))

(define S (PEG:lazy
           (PEG:end A)))

(define A (PEG:lazy
           (PEG:choice
            (PEG:apply (lambda (p _ a) (list '+ p a)) P PLUS A)
            (PEG:apply (lambda (p _ a) (list '- p a)) P MINUS A)
            P)))

(define P (PEG:lazy
           (PEG:choice
            (PEG:between LPAREN A RPAREN)
            ONE)))


(write (parse-string S "(1+1+(1-(1+(1-(1+1)))))"))
(newline)

peg.scm

(import (scheme base)
        (scheme write))

; paresr :: i ->  {(r . i) or #f}

(define (PEG:disj a b)
  (lambda (i)
    (or (a i) (b i))))

(define (PEG:conj a b)
  (lambda (i)
    (let ((x (a i)))
      (and x
           (let ((y (b (cdr x))))
             (and y
                  `(,(cons (car x) (car y)) . ,(cdr y))))))))

(define PEG:true
  (lambda (i) `(#f . ,i)))

(define PEG:fail
  (lambda (i) #f))

(define (PEG:not a)
  (lambda (i)
    (and (not (a i)) `(#f . ,i))))

(define (PEG:map f p)
  (lambda (i)
    (let ((x (p i)))
      (and x `(,(f (car x)) . ,(cdr x))))))

(define-syntax PEG:lazy
  (syntax-rules ()
    ((_ expr)
     (lambda (i) (expr i)))))


;;; aux

(define (PEG:or x . xs)
  (if (null? xs)
      x
      (PEG:disj x (apply PEG:or xs))))

(define PEG:cons PEG:conj)
(define PEG:null (PEG:map (lambda (_) '()) PEG:true))

(define (PEG:list . args)
  (if (null? args)
      PEG:null
      (PEG:cons (car args) (apply PEG:list (cdr args)))))

(define (PEG:many a)
  (PEG:lazy
   (PEG:or
      (PEG:cons a (PEG:many a))
      PEG:null)))

(define (PEG:and a)
  (PEG:not (PEG:not a)))

(define (PEG:optional a)
  (PEG:or a PEG:true))


;;; string stream parser

(define input #f)

(define (PEG:string str)
  (lambda (i)
    (let ((j (min (+ i (string-length str)) (string-length input))))
      (and (equal? str (string-copy input i j))
           `(,str . ,j)))))

(define PEG:any
  (lambda (i)
    (and (< i (string-length input))
         `(,(string-ref input i) . ,(+ i 1)))))

(define PEG:eof
  (PEG:not PEG:any))

(define (parse rule)
  (rule 0))

(define (set-input! str)
  (set! input str))


;;; test case

(set-input! "(((((((((((((1)))))))))))))")

(define LPAREN (PEG:string "("))
(define RPAREN (PEG:string ")"))

(define PLUS (PEG:string "+"))
(define MINUS (PEG:string "-"))

(define ONE (PEG:string "1"))

(define S (PEG:lazy (PEG:list A PEG:eof)))
(define A (PEG:lazy (PEG:or (PEG:list P PLUS A) (PEG:list P MINUS A) P)))
(define P (PEG:lazy (PEG:or (PEG:list LPAREN A RPAREN) ONE)))

(write (parse S))
(newline)