(define-module (language python module re compile)
  #:use-module (language python module re parser)
  #:use-module (language python module re flags)
  #: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 f-reg! f-and! f-test N M X XL f-pk
		 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 (f-flags a b f)
  (<p-lambda> (c)
     (let* ((flags (fluid-ref *flags*))
            (newfl (logand (logior a flags) (lognot b)))
            (p     P)
            (cc    CC))
       (<with-bind>
        ((P   (lambda ()
                (fluid-set! *flags* flags)
                (p)))
         (CC  (lambda (s p)
                (let ((pp (lambda ()
                            (fluid-set! *flags* newfl)
                            (p))))
                  (fluid-set! *flags* flags)
                  (cc s pp)))))
        (<code> (fluid-set! *flags* newfl))
        (.. c2 (f c))
        (<p-cc> c2)))))

(define (f-flags2 a b)
  (<p-lambda> (c)
     (let* ((flags (fluid-ref *flags*))
            (newfl (logand (logior a flags) (lognot b)))
            (p     P))
       (<with-bind>
        ((P   (lambda ()
                       (fluid-set! *flags* flags)
                       (p))))
        (<code> (fluid-set! *flags* newfl))
        (<p-cc> c)))))
  
(define startline
  (<pp-lambda> (L c)
     (when (= N 0)
       (<p-cc> (wrap L c)))))

(define dotall
  (<pp-lambda> (L c)
   (let ((x (fluid-ref *flags*)))
     (when (not (= 0 (logand x DOTALL)))
       (<p-cc> (wrap L c))))))

(define multiline
  (<pp-lambda> (L c)
   (let ((x (fluid-ref *flags*)))
     (when (not (= 0 (logand x DOTALL)))
       (<p-cc> (wrap L c))))))

(define (gt f)
  (<pp-lambda> (L c)
    (let ((x #f))
    (<or>           
     (<and>
      (.. c* (f-rev '()))
      (.. c2 (f (list L '())))
      (<code> (set! x c2))
      <fail>)
     (when x
       (<p-cc> (wrap (car x) c)))))))


(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)))
    ((#:seq x)
     (reverse-form x))
    ((#:seq . l)
     (cons #:seq (reverse (map reverse-form l))))
    ((#:sub f)
     (list #:group (reverse-form f)))
    ((#:?P< n f)
     (list #:?P< n (reverse-form f)))
    ((#:?: f)
     (reverse-form f))
    ((#:flags a b f)
     (list #:flags a b (reverse-form f)))
    ((#:flags2 a)
     (list #:flags2 a))
    ((#:?P= name)
     (#:?P=-rev name))
    ((#:?P=-rev name)
     (#:?P= name))
    ((#:?if name yes no)
     (list #:if name (reverse-form yes) (reverse-form no)))
    ((#:?=  f) (list #:?= (reverse-form f)))
    ((#:?!  f) (list #:?= (reverse-form f)))
    ((#:?<= f) (list #:?<=-rev f))
    ((#:?<! f) (list #:?<!-rev f))
    ((#:?<=-rev f) (list #:?<= f))
    ((#:?<!-rev f) (list #:?<! f))
    ((#:not f) (list #:not (reverse-form f)))
    (#:$   #:^)
    (#:^   #:$)
    (#:dot #:dot)
    ((#:op  x #:* ) (list #:op  (reverse-form x) #:*)) 
    ((#:op  x #:+ ) (list #:op  (reverse-form x) #:+)) 
    ((#:op  x (#:rep  m n)) (list #:op  (reverse-form x) (list #:rep  m n)))
    ((#:op  x (#:rep  m  )) (list #:op  (reverse-form x) (list #:rep  m)))
    ((#:op  x (#:rep? m n)) (list #:op  (reverse-form x) (list #:rep?  m n)))
    ((#:op  x (#:rep? m  )) (list #:op  (reverse-form x) (list #:rep?  m)))
    ((#:op  x #:? ) (list #:op  (reverse-form x) #:?)) 
    ((#:op  x #:*?) (list #:op  (reverse-form x) #:*?)) 
    ((#:op  x #:+?) (list #:op  (reverse-form x) #:+?)) 
    ((#:op  x #:??) (list #:op  (reverse-form x) #:??))
    ((and a (#:ch (#:class x)))     a)
    ((and a (#:ch x))               a)
    ((and a (#:range x))            a)
    ((and a (#:bracket not ch ...)) a)))

    
(define f-w
  (f-or! (f-test! (lambda (x)
                    (let ((y (fluid-ref *flags*)))
                      (and
                       (= (logand y ASCII) 0)
                       (or (char-numeric? x)
                           (char-alphabetic? x))))))
                                  
         (f-tag  "_")
         (f-reg! "a-zA-Z0-9")))
         
(define f-d
  (f-or!
   (f-test! (lambda (x)
              (let ((y (fluid-ref *flags*)))
                (and
                 (= (logand y ASCII) 0)
                 (char-numeric? x)))))
   (f-reg! "0-9")))

(define f-s
  (f-or!
   (f-test!
    (lambda (x)
      (let ((fl (fluid-ref *flags*)))
        (and
         (= (logand fl ASCII) 0)
         (char-whitespace? x)))))
   f-nl!
   (f-reg! "[\n\r \t\f\v]")))

(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 (mask-on a b)
  (let lp ((l (string->list a)) (f 0))
    (match l
      ((#\a . l)
       (lp l (logior f ASCII)))
      ((#\i . l)
       (lp l (logior f IGNORECASE)))
      ((#\L . l)
       (lp l (logior f LOCALE)))
      ((#\m . l)
       (lp l (logior f MULTILINE)))
      ((#\s . l)
       (lp l (logior f DOTALL)))
      ((#\x . l)
       (lp l (logior f VERBOSE)))
      ((_ . l)
       (lp l f))
      (()
       f))))

(define (mask-off a b)
  (let lp ((l (string->list b)) (f (if (member #\u (string->list a))
                                       ASCII
                                       0)))
    (match l
      ((#\i . l)
       (lp l (logior f IGNORECASE)))
      ((#\m . l)
       (lp l (logior f MULTILINE)))
      ((#\s . l)
       (lp l (logior f DOTALL)))
      ((#\x . l)
       (lp l (logior f VERBOSE)))
      ((_ . l)
       (lp l f))
      (()
       f))))
      
      
(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) (gt (compile (reverse-form f))))
    ((#:?<! f) (f-seq (f-not (f-seq f-rev (compile (reverse-form f))))
                      f-true))
    ((#:?<=-rev f) (gt (compile f)))
    ((#:?<!-rev f) (f-seq (f-not (f-seq f-rev (compile f)))
                      f-true))
    ((#:not f) (f-and (f-not (compile 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-or! f-eof
            (f-and multiline
                   f-nl
                   f-true)))
    (#:^
     (f-or! (f-nm 0 1)
            (f-and multiline
                   startline
                   f-true)))
    (#:dot
     (f-or! (fw (f-reg! "."))
            (f-and
             dotall
             (fw f-nl!))))
    ((#:flags a b f)
     (let ((maskon  (mask-on  a b))
           (maskoff (mask-off a b)))
       (f-flags maskon maskoff (compile f))))
    
    ((#:flags2 a)
     (let ((maskon  (mask-on  a ""))
           (maskoff (mask-off a "")))
       (f-flags2 maskon maskoff)))
    ((#: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)
     (let ((chx (string-ref x 0)))
       (fw
        (f-test! (lambda (ch)
                   (let ((y (fluid-ref *flags*)))
                     (if (= 0 (logand y IGNORECASE))
                         (eq? ch chx)
                         (if (= 0 (logand y ASCII))
                             (eq? (char-upcase chx) (char-upcase ch))
                             (if (and (< (char->integer ch)  128)
                                      (< (char->integer chx) 128))
                                 (eq? (char-upcase chx) (char-upcase ch))
                                 (eq? chx ch))))))))))
    ((#:bracket not ch ...)
     (let ((f (apply f-or!
                     (map (lambda (x)
                            (match x
			      ((#:range ch1 ch2)
			       (f-reg! (format #f "[~a-~a]" ch1 ch2)))
			      ((#:ch (#:class ch))
                               (get-class ch))
                              ((#:ch ch)
                               (compile (list #:ch 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)))