(define-module (language python modules re)
  #:export())


(define-sytax-rule (mk n tag str) (define n (f-seq tag (f-tag str))))
(mk f-. #:. ".")
(mk f-^ #:^ "^")
(mk f-$ #:$ "$")

(define subexpr (f-list #:sub
                        (f-seq (f-tag "(") f-start ee f-end (f-tag ")"))))

(define f-back
  (f-or (f-list #:class (mk-token (f-reg! "[AZbBdDsSwS]")))
        (mk-token (f-reg "."))))

(define (ch not)
  (f-list #:ch
          (f-or! (f-seq (f-char #\\) f-back)
                 (mk-token (f-not! not)))))

(define bbody (f-cons (ch "[\\]") (ff* (ch "[]\\]"))))

(define choice
  (f-cons #:bracket
          (f-or!
           (f-seq "[^]" (f-out (list #:ch "^")))
           (f-cons*
            (f-tag "[")
            (f? (f-seq (f-tag "^") (f-out #t)))
            bbody))))

(define-syntax-rule (mk-post q* str tag)
  (define q*
    (<p-lambda> (c)
      (.. c2  ((f-tag str) c))
      (<p-cc> (cons (list tag (car c)) (cdr c))))))

(mk-post q* "*" #:*)
(mk-post q? "?" #:?)
(mk-post q+ "+" #:+)
(mk-post q* "*?" #:*?)
(mk-post q? "??" #:??)
(mk-post q+ "+?" #:+?)

(define q-or
  (<p-lambda> (c)     
    (.. (c2) ((f-seq (f-tag "|") e) '()))
    (<p-cc> (list #:or c c2))))
  
(define q?
  (<p-lambda> (c)
    (.. c2  ((f-tag "*") c))
    (<p-cc> (cons (list #:* (car c)) (cdr c)))))

(define group
  (lambda (f)
    (<p-lambda> (c1)
      (.. c2 (f '()))
      (with ((L (cons (cons I c2) L))
             (I (+ i 1)))
        (<p-cc> (list #:list (#:append c1 c2)))))))

(define group-name
  (lambda (f name)
    (<p-lambda> (c1)
      (.. c2 (f '()))
      (with ((L (cons* (cons name c2) (cons I c2) L))
             (I (+ i 1)))
        (<p-cc> (list #:list (#:append c1 c2)))))))

(define (incant name)
  (<p-lambda> (c)
    (let ((r (assoc name L)))
      (if r
          (<and> (.. (f-tag (cdr r))))
          (<code> (error "group is not existing in the history"))))))

(define (incant-rev name)
  (<p-lambda> (c)
    (let ((r (assoc name L)))
      (if r
          (<and> (.. (f-tag (reverse (cdr r)))))
          (<code> (error "group is not existing in the history"))))))

(define (reverse-form x)
  (match x
    ((#:or x y)
     (list #:or (reverse-form x) (reverse-form y)))
    ((#:group f)
     (list #:group (reverse-form f)))
    ((#:?P< f n)
     (list #:?P< (reverse-form f) n))
    ((#:?: f)
     (reverse-form f))
    ((#:?P= name)
     (#:?P=-rev name))
    ((#:?P=-rev name)
     (#:?P= name))
    ((#:?if name yes no)
     (list #:?if-rev name (reverse-form yes) (reverse-form no)))
    ((#:?if-rev name yes no)
     (list #:?if name (reverse-form yes) (reverse-form no)))
    ((#:?=  f    ) (list #:?=  (reverse-form f)))
    ((#:?!  f    ) (list #:?!  (reverse-form f)))
    ((#:?<= f    ) (list #:?<= f))
    ((#:?<! f    ) (list #:?<! f))
    ((#:*   x    ) (list #:*   (reverse-form x)))
    ((#:+   x    ) (list #:+   (reverse-form x)))
    ((#:mn  x m n) (list #:mn  (reverse-form x) m n))
    ((#:?   x    ) (list #:?   (reverse-form x)))
    ((#:*?  x    ) (list #:*?  (reverse-form x)))
    ((#:+?  x    ) (list #:+?  (reverse-form x)))
    ((#:??  x    ) (list #:??  (reverse-form x)))
    ((:mn?  x m n) (list #:mn? (reverse-form x) m n))
    ((#:ch  x    ) (list #:ch  x))
    ((#:bracket . l) (cons #:bracket l))
    ((x . l) (map reverse-form (cons x l)))
    (x x)))
    
(define (compile x)
  (match x
    ((#:or x y)
     (f-or (compile x) (compile y)))
    ((#:group f)
     (group (compile f)))
    ((#:?P< f n)
     (group-name (compile f) n))
    ((#:?: f)
     (compile f))
    ((#:?P= name)
     (incant name))
    ((#:?P=-rev name)
     (incant-rev name))
    ((#:?=  f) (f-and (compile f) f-true))
    ((#:?!  f) (f-and (f-not (compile f)) f-true))
    ((#:?<= f) (f-and (f-seq f-rev (compile (reverse-form f))) f-true))
    ((#:?<! f) (f-and (f-seq f-rev (f-not (compile (reverse-form f)))) f-true))
    ((#:?if name yes no)
     (f-or (f-seq (incant name) yes)
           no))
    ((#:?if-rev name yes no)
     (f-or (f-seq yes (incant-rev name))
           no))
    ((#:*   x    ) (g*   (compile x)    ))
    ((#:+   x    ) (g+   (compile x)    ))
    ((#:mn  x m n) (gmn  (commile x) m n))
    ((#:?   x    ) (g?   (compile x)    ))
    ((#:*?  x    ) (ng*  (compile x)    ))
    ((#:+?  x    ) (ng+  (compile x)    ))
    ((#:??  x    ) (ng?  (compile x)    ))
    ((:mn?  x m n) (ngmn (compile x) m n))
    ((#:ch (#:class x))
     (get-class ch))
    ((#:ch x)
     (f-tag! x))    
    ((#:bracket not ch ...)
     (let ((f (apply f-or!
                     (map (lambda (x)
                            (match x
                              ((#:ch (:class ch))
                               (get-class ch))
                              ((#:ch ch)
                               (f-tag! ch)))) ch))))
       
       (if not
           (f-not f)
           f)))))

(define (id c) c)
(define (e-match     e)
  (f-seq (f-or! (f-mute e) (f-return #f))
         (f-retfkn id)))

(define (e-fullmatch e)
  (f-or! (f-seq (f-mute e) f-eof (f-retfkn id))
         (f-return #f)))

(define (e-search    e)
  (f-or! (f-seq (f-mute e) (f-retfkn id))
         (f-seq (f-take 1) (Ds (e-search e)))
         (f-return None)))


(define (e-sub e str)
  (f-or! (f-seq (f-subst (f-mute e) str) (Ds (e-sub e str)))
         (f-seq (f-take 1) (Ds (e-search e)))
         (f-out-written)))

(define (e-subn e str)
  (let lp ((i 0))
    (f-or! (f-seq (f-subst (f-mute e) str) (Ds (lp (+ i 1))))
           (f-seq (f-take 1) (Ds (e-search e)))
           (f-seq (f-out-written) (f-retfkn (lambda (c) (values c i)))))))

(define (e-split e)
  (f-or! (f-cons (f-seq (mk-token f-out-written) (f-mute e)) (e-split e))
         (f-cons (f-out-remaining) (f-out '()))))

(define* (findall x s (#:flags 0))
  (call-with-values (lambda () (parse e-search x s flags))
    (lambda (m cont)
      (let lp ((m m) (cont cont))
        (if (eq? m None)
            '()
            (cons m (call-with-values cont lp)))))))

(define* (finditer x s (#:flags 0))
  ((make-generator ()
    (lambda (yield)              
      (call-with-values (lambda () (parse e-search x s flags))
        (lambda (m cont)
          (let lp ((m m) (cont cont))
            (if (eq? m None)
                #f
                (begin
                  (yield m)
                  (call-with-values cont lp))))))))))