(define-module (language python compile)
  #:use-module (ice-9 match)
  #:use-module (ice-9 pretty-print)
  #:export (comp))

(define-syntax call
  (syntax-rules ()
    ((_ (f) . l) (f . l))))

(define (fold f init l)
  (if (pair? l)
      (fold f (f (car l) init) (cdr l))
      init))

(define (pr . x)
  (define port (open-file "/home/stis/src/python-on-guile/log.txt" "a"))
  (with-output-to-port port
    (lambda ()
      (pretty-print x)))
  (close port)
  (car (reverse x)))

(define (pf x)
  (define port (open-file "/home/stis/src/python-on-guile/compile.log" "a"))
  (with-output-to-port port
    (lambda () (pretty-print (syntax->datum x)) x))
  (close port)
  x)

(define (C x) `(@@ (language python compile) ,x))
(define (O x) `(@@ (oop pf-objects) ,x))
(define (G x) `(@ (guile) ,x))

(define (union as vs)
  (let lp ((as as) (vs vs))
    (match as
      ((x . as)
       (if (member x vs)
           (lp as vs)
           (lp as (cons x vs))))
      (()
       vs))))

(define (diff as vs)
  (let lp ((as as) (rs '()))
    (match as
      ((x . as)
       (if (member x vs)
           (lp as rs)
           (lp as (cons x rs))))
      (()
       rs))))

(define (get-globals code)
  (let lp ((vs (glob code '())) (rs (scope code '())))
    (match vs
      ((x . l)
       (if (member x rs)
           (lp l rs)
           (lp l (cons x rs))))
      (()
       rs))))

(define (glob x vs)
  (match x
    ((#:global . l)
     (let lp ((l l) (vs vs))
       (match l
         (((#:identifier v . _) . l)
          (let ((s (string->symbol v)))            
            (if (member s vs)
                (lp l vs)
                (lp l (cons s vs)))))
         (()
          vs))))
    ((x . y)
     (glob y (glob x vs)))
    (x vs)))

(define (scope x vs)
  (match x
    ((#:def  (#:identifier f . _) . _)
     (union (list (string->symbol f)) vs))
    ((#:lambdef . _)
     vs)
    ((#:classdef . _)
     vs)
    ((#:global . _)
     vs)
    ((#:identifier v . _)
     (let ((s (string->symbol v)))
       (if (member s vs)
           vs
           (cons s vs))))
    ((x . y)
     (scope y (scope x vs)))
    (_ vs)))

(define (defs x vs)
  (match x
    ((#:def  (#:identifier f . _) . _)
     (union (list (string->symbol f)) vs))
    ((#:lambdef . _)
     vs)
    ((#:class . _)
     vs)
    ((#:global . _)
     vs)
    ((x . y)
     (defs y (defs x vs)))
    (_ vs)))

(define (g vs e)
  (lambda (x) (e vs x)))

(define return (make-fluid 'error-return))

(define (make-set vs x u)
  (match x
    ((#:test (#:power (#:identifier v . _) addings . _) . _)
     (let ((v (string->symbol v)))
       (if (null? addings)
           `(set! ,v ,u)
           (let* ((rev (reverse addings))
                  (las (car rev))
                  (new (reverse (cdr rev))))
             `(,(O 'set) ,(let lp ((v v) (new new))
                             (match new
                               ((x . new)
                                (lp `(,(O 'ref) ,v ,(exp vs x)) ',new))
                               (() v)))
               ',(exp vs las) ,u)))))))

             
     
(define (exp vs x)
  (match (pr x)
    ((#:power x () . #f)
     (exp vs x))

    ;; Function calls (x1:x1.y.f(1) + x2:x2.y.f(2)) will do functional calls
    ((#:power vf ((and trailer (#:identifier _ . _)) ...
                  (#:arglist (args ...) #f #f)) . #f)
     (let ((args (map (g vs exp) args)))
       (match vf
         ((#:f (#:identifier f . _) e)
          (let ((obj  (gensym "obj"))
                (l    (gensym "l")))
            '(call-with-values (lambda () (fcall (,(exp vs e)
                                                  ,@(map (g vd exp) trailer))
                                                 ,@args))
               (lambda (,obj . ,l)
                 `(set! ,(string->symbol f) ,obj)
                 (apply 'values ,l)))))
         (x
          `(,(C 'call) (,(exp vs x) ,@(map (g vs exp) trailer)) ,@args)))))
                                                
    ((#:identifier x . _)
     (string->symbol x))

    ((#:string x)
     x)
    
    (((and x (or #:+ #:- #:* #:/)) . l)
     (cons (keyword->symbol x) (map (g vs exp) l)))

    ((#:u~ x)
     (list 'lognot (exp vs x)))

    ((#:band . l)
     (cons 'logand (map (g vs exp) l)))

    ((#:bxor . l)
     (cons 'logxor (map (g vs exp) l)))

    ((#:bor . l)
     (cons 'logior (map (g vs exp) l)))

    ((#:not x)
     (list 'not (exp vs x)))

    ((#:or . x)
     (cons 'or (map (g vs exp) x)))

    ((#:and . x)
     (cons 'and (map (g vs exp) x)))
    
    ((#:test e1 #f)
     (exp vs e1))
    
    ((#:test e1 e2 e3)
     (list 'if (exp vs e2) (exp vs e1) (exp vs e3)))

    ((#:if test a ((tests . as) ...) . else)
     `(,(G 'cond)
       (,(exp vs test) ,(exp vs a))
       ,@(map (lambda (p a) (list (exp vs p) (exp vs a))) tests as)
       ,@(if else `((else ,(exp vs else))) '())))
    
    ((#:suite . l) (cons 'begin (map (g vs exp) l)))

    ((#:try x #f #f fin)
     `(dynamic-wind
        (lambda () #f)
        (lambda () ,(exp vs x))
        (lambda () ,(exp vs fin))))

    ((#:while test code #f)
     (let ((lp (gensym "lp")))
       `(let ,lp ()
          (if test
              (begin
                ,(exp vs code)
                (,lp))))))

    ((#:classdef (#:identifier class . _) parents defs)
     (let ()
       (define (filt l)
         (reverse
          (fold (lambda (x s)
                  (match x
                    (((or 'fast 'functional)) s)
                    (x (cons x s))))
                '() l)))
       (define (is-functional l)
         (fold (lambda (x pred)
                 (if pred
                     pred
                     (match x
                       (('functional) #t)
                       (_ #f)))) #f l))
       (define (is-fast l)
         (fold (lambda (x pred)
                 (if pred
                     pred
                     (match x
                       (('fast) #t)
                       (_ #f)))) #f l))
       
       
       (let* ((class   (string->symbol class))
              (parents (match parents
                         (#f
                          '())
                         ((#:arglist args . _)
                          (map (g vs exp) args))))
              (is-func (is-functional parents))
              (is-fast (is-fast       parents))
              (kind    (if is-func
                           (if is-fast
                               'mk-pf-class
                               'mk-pyf-class)
                           (if is-fast
                               'mk-p-class
                               'mk-py-class)))              
              (parents (filt parents)))
         `(define ,class (,(O 'wrap)
                          (,(O kind)
                           ,class
                           ,(map (lambda (x) `(,(O 'get-class) ,x)) parents)
                          #:const
                          ,(match (exp vs defs)
                             ((begin . l)
                              l)
                             (l l))
                          #:dynamic
                          ()))))))
                          
       
    
    ((#:for e in code . #f)
     (=> next)
     (match e
       (((#:power (#:identifier x . _) () . #f))
        (match in
          (((#:test power . _))
           (match power
             ((#:power
               (#:identifier "range" . _)
               ((#:arglist arglist . _))
               . _)
              (match arglist
                ((arg)
                 (let ((v   (gensym "v"))
                       (x   (string->symbol x))
                       (lp  (gensym "lp")))
                   `(let ((,v ,(exp vs arg)))
                      (let ,lp ((,x 0))
                           (if (< ,x ,v)
                               (begin
                                 ,(exp vs code)
                                 (,lp (+ ,x 1))))))))
                ((arg1 arg2)
                 (let ((v1   (gensym "va"))
                       (v2   (gensym "vb"))
                       (lp  (gensym "lp")))
                   `(let ((,v1 ,(exp vs arg1))
                          (,v2 ,(exp vs arg2)))
                      (let ,lp ((,x ,v1))
                           (if (< ,x ,v2)
                               (begin
                                 ,(exp vs code)
                                 (,lp (+ ,x 1))))))))
                ((arg1 arg2 arg3)
                 (let ((v1   (gensym "va"))
                       (v2   (gensym "vb"))
                       (st   (gensym "vs"))
                       (lp  (gensym "lp")))
                   `(let ((,v1 ,(exp vs arg1))
                          (,st ,(exp vs arg2))
                          (,v2 ,(exp vs arg3)))
                      (if (> st 0)
                          (let ,lp ((,x ,v1))
                               (if (< ,x ,v2)
                                   (begin
                                     ,(exp vs code)
                                     (,lp (+ ,x ,st)))))
                          (if (< st 0)
                              (let ,lp ((,x ,v1))
                                   (if (> ,x ,v2)
                                       (begin
                                         ,(exp vs code)
                                         (,lp (+ ,x ,st)))))
                              (error "range with step 0 not allowed"))))))
                (_ (next))))
             (_ (next))))
          (_ (next))))
       (_ (next))))
    
    ((#:while test code else)
     (let ((lp (gensym "lp")))
       `(let ,lp ()
          (if test
              (begin
                ,(exp vs code)
                (,lp))
              ,(exp vs else)))))
    
    ((#:try x exc else fin)
     (define (f x)
       (match else
         ((#f x)
          `(catch #t
             (lambda () ,x)
             (lambda ,(gensym "x") ,(exp vs x))))))
    
     `(dynamic-wind
        (lambda () #f)
        (lambda ()
          ,(f
            (let lp ((code (exp vs x)) (l (reverse exc)))                    
              (match l
                ((((e) c) . l)
                 (lp `(catch ,(exp vs e)
                        (lambda () ,code)
                        (lambda ,(gensym "x")
                          ,(exp vs c))) l))
                ((((e . as) c) . l)
                 (lp `(let ((,as ,(exp vs e)))
                        (catch ,as
                          (lambda () ,code)
                          (lambda ,(gensym "x")
                            ,(exp vs c)))) l))
                (()
                 code))))
          (lambda () ,(exp vs fin)))))

    ((#:def (#:identifier f . _)
            (#:types-args-list
             args
             #f #f)
            #f
            code)
     (let* ((f  (string->symbol f))
            (r  (gensym "return"))
            (as (map (lambda (x) (match x
                                  ((((#:identifier x . _) . #f) #f)
                                   (string->symbol x))))
                     args))
            (vs (union as vs))
            (ns (scope code vs))
            (df (defs code '()))
            (ls (diff (diff ns vs) df)))
       
       `(define ,f (lambda (,@as)
                     (,(C 'with-return) ,r
                      (let ,(map (lambda (x) (list x #f)) ls)
                        ,(with-fluids ((return r))
                           (exp ns code))))))))
     
    ((#:global . _)
     '(values))
    
    ((#:lambdef v e)
     (list `lambda v (exp vs e)))

    ((#:stmt l)
     (if (> (length l) 1)
         (cons 'values (map (g vs exp) l))
         (exp vs (car l))))
     

    ((#:expr-stmt (l) (#:assign))
     (exp vs l))

    ((#:expr-stmt l (#:assign u))
     (cond
      ((= (length l) (length u))
       (cons 'begin (map make-set (map (lambda x vs) l) l (map (g vs exp) u))))
      ((= (length u) 1)
       (let ((vars (map (lambda (x) (gensym "v")) l)))
         `(call-with-values (lambda () (exp vs (car u)))
            (lambda vars
              ,@(map make-set l vars)))))))
                             
            

    ((#:return . x)
     `(,(fluid-ref return) ,@(map (g vs exp) x)))
    
    ((#:expr-stmt
      ((#:test (#:power (#:identifier v . _) () . #f) #f))
      (#:assign (l)))
     (let ((s (string->symbol v)))
       `(set! ,s ,(exp vs l))))
                           
    ((#:comp x #f)
     (exp vs x))

    ((#:comp x (op . y))
     (define (tr op x y)
       (match op
         ((or "<" ">" "<=" ">=")
          (list (G (string->symbol op)) x y))
         ("!="    (list 'not (list 'equal? x y)))
         ("=="    (list 'equal? x y))
         ("is"    (list 'eq? x y))
         ("isnot" (list 'not (list 'eq? x y)))
         ("in"    (list 'member x y))
         ("notin" (list 'not (list 'member x y)))
         ("<>"    (list 'not (list 'equal? x y)))))
     (tr op (exp vs x) (exp vs y)))
    
    (x x)))

(define (comp x)
  (define start
    (match (pr 'start x)
      (((#:stmt
         ((#:expr-stmt
           ((#:test
             (#:power
              (#:identifier "module" . _)
              ((#:arglist arglist #f #f))
              . #f) #f))
           (#:assign)))) . _)
       (let ()
         (define args
           (map (lambda (x)
                  (exp '() x))
                arglist))

         `((,(G 'define-module) (language python module ,@args)))))
      (x '())))
  
  (if (pair? start)
      (set! x (cdr x)))

  (let ((globs (get-globals x)))
    `(begin
       ,@start
       ,@(map (lambda (s) `(,(C 'var) ,s)) globs)
       ,@(map (g globs exp) x))))

(define-syntax with-return
  (lambda (x)
    (define (analyze ret x)
      (syntax-case x (begin let if)
        ((begin a ... b)
         #`(begin a ... #,(analyze ret #'b)))
        ((let lp v a ... b)
         (symbol? (syntax->datum #'lp))
         #`(let lp v a ... #,(analyze ret #'b)))
        ((let v a ... b)
         #`(let v a ... #,(analyze ret #'b)))
        ((if p a b)
         #`(if p #,(analyze ret #'a) #,(analyze ret #'b)))
        ((if p a)
         #`(if p #,(analyze ret #'a)))
        ((return a b ...)
         (equal? (syntax->datum #'return) (syntax->datum ret))
         (if (eq? #'(b ...) '())
             #'a
             #`(values a b ...)))
        (x #'x)))

    (define (is-ec ret x tail)
      (syntax-case x (begin let)
        ((begin a ... b)
         #t
         (or
          (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
          (is-ec ret #'b tail)))
        
        ((let lp ((y x) ...) a ... b)
         (symbol? (syntax->datum #'lp))
         (or
          (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
          (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
          (is-ec ret #'b tail)))
        
        ((let ((y x) ...) a ... b)
         #t
         (or
          (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
          (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
          (is-ec ret #'b tail)))
        
        ((if p a b)
         #t
         (or
          (is-ec ret #'p #f)
          (is-ec ret #'a tail)
          (is-ec ret #'b tail)))
        ((if p a)
         #t
         (or
          (is-ec ret #'p #f)
          (is-ec ret #'a tail)))

        ((return a b ...)
         (equal? (syntax->datum #'return) (syntax->datum ret))
         (not tail))

        ((a ...)
         #t
         (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)))

        (x
         #t
         #f)))

    (syntax-case x ()
      ((_ ret  l)
       (let ((code (analyze #'ret #'l)))
         (if (is-ec #'ret #'l #t)
             #`(let/ec ret #,code)
             code))))))

(define-syntax-rule (var v)
  (if (defined? 'v)
      (values)
      (define! 'v #f)))