(define-module (language python module re compile)
  #:use-module (language python module re parser)
  #:use-module (language python list)
  #:use-module (language python string)
  #:use-module ((parser stis-parser) #:select
		((parse . stisparse) <p-lambda> <p-cc> .. f-nl! f-nl
		 f-tag! f-tag f-seq f-or f-or! f-and f-true g* g+ gmn ng* ng+ ngmn
		 g? ng? f-test! f-eof f-not! f-prev f-not f-out f-rev *whitespace*
		 f-nm f-pos))
  
  #:use-module (parser stis-parser macros)
  #:use-module (ice-9 match)
  #:export (compile-reg test-reg parse))

(define-syntax-rule (<pp-lambda> (a b) . code)
  (<p-lambda> (d)
    (let ((a (car   d))
	  (b (cadr  d)))
      . code)))

(define wrap list)

(define (fw f)
  (<pp-lambda> (L c)
    (.. c2 (f c))
    (<p-cc> (wrap L c2))))

(define-syntax-rule (group f)
  (let ()
    (define-syntax-rule (mac s) (lambda (x n m) (set! s x)))
    (let ((I  (new-group))
	  (ff f))
      (<pp-lambda> (L c)
	(let ((e -1)
	      (s -1))
         (.. c2 ((f-seq (f-pos (mac s)) ff (f-pos (mac e)))(list L c))) 
	 (let* ((L (car c2))
		(L (cons (cons I (list (strit c (cadr c2)) s e)) L)))
	   (<p-cc> (wrap L (cadr c2)))))))))

(define-syntax-rule (group-name f name)
  (let ()
    (define-syntax-rule (mac s) (lambda (x n m) (set! s x)))
    (let* ((n  (new-name name))
	   (ff f))
      (<pp-lambda> (L c)
       (let ((e -1)
	     (s -1))	 
	 (.. c2 ((f-seq (f-pos (mac s)) ff (f-pos (mac e))) (list L c))) 
	 (let* ((L  (car  c2))
		(c2 (cadr c2))
		(L  (cons (cons n (list (strit c c2) s e)) L)))
	   (<p-cc> (wrap L c2))))))))

(define (strit u v)
  (let lp ((v v) (r '()))
    (if (eq? u v)
	(list->string r)
	(lp (cdr v) (cons (car v) r)))))

(define (incant name)
  (<p-lambda> (c)
    (let* ((L (cadr c))
	   (r (if (number? name)
		  (let lp ((l L))
		    (define (f x u l)
		      (if (= x name)
			  u
			  (lp l)))
		    
		    (match l
		      (((x . u) . l)
		       (if (pair? x)
			   (f (cdr x) (car u) l)
			   (f x       (car u) l)))
		      (() (error (+ "could not incant " name)))))
		  (let lp ((l L))
		    (define (f x u l)
		      (if (equal? x name)
			  u
			  (lp l)))
		    
		    (match l
		      (((x . u) . l)
		       (if (pair? x)
			   (f (car x) u l)
			   (f x       u l)))
		      (() (error (+ "could not incant " name))))))))
		  	   
		       
			
      (if r
          (<and> (.. ((fw (f-tag! r)) c)))
          (<code> (error "group is not existing in the history"))))))

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

(define (reverse-form x)
  (match x
    ((#:or x)
     (reverse-form x))
    ((#:or . l)
     (cons #:or (map reverse-form l)))
    ((#:sub 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 f-w (f-test! (lambda (x) (or (char-numeric? x) (char-alphabetic? x) (eq? x #\_)))))
(define f-d (f-test! (lambda (x) (or (char-numeric? x)))))
(define f-s (f-test! (lambda (x) (or (char-whitespace? x)))))
(define (get-class tag)
   (match tag
      ("n"  f-nl!)
      ("t"  (f-tag! "\t"))
      ("r"  (f-tag! "\r"))
      ("a"  (f-tag! "\a"))
      ("v"  (f-tag! "\v"))
      ("f"  (f-tag! "\f"))
      ("A"  (f-nm 0 1))
      ("b"  (f-or! (f-and (f-or! (f-nm 0 1) (f-prev 1 (f-not f-w)))
                          (f-or! f-eof f-w)
                          f-true)
		   (f-and (f-or! (f-nm 0 1) (f-prev 1 f-w))
                          (f-or! f-eof (f-not f-w))
                          f-true)))
      ("B"  (f-or! (f-and (f-or! (f-nm 0 1) (f-prev 1 (f-not f-w)))
                          (f-or! f-eof (f-not f-w))
                          f-true)
		   (f-and (f-or! (f-nm 0 1) (f-prev 1 f-w))
                          (f-or! f-eof f-w)
                          f-true)))
      ("d"  f-d)
      ("D"  (f-not! f-d))
      ("w"  f-w)
      ("W"  (f-not! f-w))
      ("s"  f-s)
      ("S"  (f-not! f-s))
      ("Z"  f-eof)
      (x    (f-tag! x))))

(define groups     (make-fluid 0))
(define groupindex (make-fluid 0))
(define (init)
  (fluid-set! groups     1)
  (fluid-set! groupindex (make-hash-table)))
(define (new-group)
  (let ((i (fluid-ref groups)))
    (fluid-set! groups (+ i 1))
    i))
(define (new-name n)
  (let ((i (fluid-ref groups)))
    (hash-set! (fluid-ref groupindex) n i)
    (fluid-set! groups (+ i 1))
    (cons n i)))
   
(define (compile x)
  (match x
    ((#:or x)
     (compile x))
    ((#:or . l)     
     (apply f-or (map compile l)))
    ((#:seq x)
     (compile x))
    ((#:seq . l)
     (apply f-seq (map compile l)))
    ((#:sub f)
     (group (compile f)))
    ((#:?P< n f)
     (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))
    (#:$  f-eof)
    (#:^  (f-nm 0 1))
    ((#:op  x #:* ) (g*   (compile x)    ))
    ((#:op  x #:+ ) (g+   (compile x)    ))
    ((#:op  x (#:rep  m n)) (gmn   (compile x) m n))
    ((#:op  x (#:rep  m  )) (gmn   (compile x) m m))
    ((#:op  x (#:rep? m n)) (ngmn  (compile x) m n))
    ((#:op  x (#:rep? m  )) (ngmn  (compile x) m m))
    ((#:op  x #:? ) (g?   (compile x)    ))
    ((#:op  x #:*?) (ng*  (compile x)    ))
    ((#:op  x #:+?) (ng+  (compile x)    ))
    ((#:op  x #:??) (ng?  (compile x)    ))
    ((#:ch (#:class x))
     (fw (get-class x)))
    ((#:ch x)
     (fw (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 (maybe-add-nk x)
   (if (equal? (pylist-ref x (- (len x) 1)) "\n")
       (+ x "\n")
       x))
      
(define (compile-reg x)
  (init)
  (let ((p (f-seq (f-out '(() ())) (compile (parse-reg x)))))
    (list p (fluid-ref groups) (fluid-ref groupindex))))

(define (test-reg y x)
  (with-fluids ((*whitespace* f-true))
    (stisparse (maybe-add-nk y)  (car (compile-reg x)))))

(define (parse y x)
  (with-fluids ((*whitespace* f-true))
    (stisparse (maybe-add-nk y) x)))