(define-module (language python parser)
  #:use-module (logic guile-log)
  #:use-module (ice-9 match)
  #:use-module (ice-9 pretty-print)
  #:use-module (language python parser-tool)
  #:export (p))

(define do-print #t)
(define pp
  (case-lambda
    ((s x)
     (when do-print
       (pretty-print `(,s ,(syntax->datum x))))
     x)
    ((x)
     (when do-print
       (pretty-print (syntax->datum x)))
     x)))


(define  divide truncate/)
;; +++++++++++++++++++++++++++++++++++++ SCANNER SUBSECTION
(define com (f-seq "#" (f* (f-not f-nl)) f-nl))
(define w   (f-reg "[\t\r| ]"))
(define ws+ (f+ (f-or (f-reg "[\t\r| ]") com)))
(define ws* (f+ (f-or (f-reg "[\t\r| ]") com)))
(define ws ws*)
(define nl f-nl)

(define (wn_ n i)
  (<p-lambda> (c)
    (cond
     ((> i n) <fail>)
     ((= i n)
      (.. ((f-not w) c)))
     ((< i n)
      (<or>
       (<and>
	(.. (c) ((f-tag " ") c))
	(.. ((wn_ n (+ i 1)) c)))
       (<and>
	(.. (c) ((f-tag "\t") c))
	(.. ((wn_ n (divide (+ i 8) 8)) c)))
       (<and>
	(.. (c) ((f-tag "\r") c))
	(.. ((wn_ n i) c))))))))

(define (wn+_ n i)
  (<p-lambda> (c)
    (cond
     ((> i n)
      (<let>  ((Inew (cons i INDENT)))
	(<syntax-parameterize> ((INDENT (lambda x #'Inew)))
	  (<p-cc> c))))
     ((< i n)
      (<or>
       (<and>
	(.. (c) ((f-tag " ") c))
	(.. ((wn+_ n (+ i 1)) c)))
       (<and>
	(.. (c) ((f-tag "\t") c))
	(.. ((wn+_ n (divide (+ i 8) 8)) c)))
       (<and>
	(.. (c) ((f-tag "\r") c))
	(.. ((wn+_ n i) c))))))))

(define (wn+ n) (wn+_ n 0))
(define (wn n) (wn_ n 0))

(define indent= wn)
(define indent+ wn+)
(define indent-
  (<p-lambda> (c)
    (<let> ((i (cdr INDENT)))
       (<syntax-parameterize> ((INDENT (lambda x #'i)))
	 (<p-cc> c)))))


(define ih  (f-reg! "a-zA-Z_"))
(define i.. (f-or ih (f-reg! "0-9")))
(define identifier_ (f-seq ih (f* i..)))

(define keyw (make-hash-table))
(for-each
 (lambda (x) (hash-set! keyw x #t))
 '(False None True and as assert break class continue def
	 del elif else except finally for from global if import
	 in is lambda nonlocal not or pass raise return try
	 while with yield))

(define decimal (mk-token (f-seq (f-reg! "[1-9]") (f* (f-reg! "[0-9]")))))
(define oct     (mk-token
		 (mk-token 
		  (f-seq "0" (f-reg "[oO]") (f+ (f-reg! "[0-7]"))))))
(define hex     (mk-token
		 (f-seq "0" (f-reg "[xX]") (f+ (f-reg! "[0-7a-fA-F]")))))
(define bin     (mk-token 
		 (f-seq "0" (f-reg "[bB]") (f+ (f-reg! "[01]")))))

(define integer
  (<p-lambda> (c)
    (<and!>
     (<or>
      (<and>
       (.. (c) (decimal c))
       (<p-cc> (string->number c 10)))
      (<and>
       (.. (c) (oct c))
       (<p-cc> (string->number c 8)))
      (<and>
       (.. (c) (hex c))
       (<p-cc> (string->number c 16)))
      (<and>
       (.. (c) (bin c))
       (<p-cc> (string->number c 2)))))))

(define intpart    (f+ (f-reg! "[0-9]")))
(define fraction (f-seq (f-tag! ".") intpart))
(define exponent (f-seq (f-reg! "[eE]") (f? (f-reg! "[+-]")) intpart))
(define pointfloat (f-or! (f-seq (f? intpart) fraction) 
			  (f-seq intpart (f-tag! "."))))
(define exponentfloat (f-seq (f-or intpart pointfloat) exponent))

(define floatnumber (mk-token (f-or! exponentfloat pointfloat)))
(define float
  (<p-lambda> (c)
    (.. (c) (floatnumber c))
    (<p-cc> (string->number c))))
  
(define imagnumber (mk-token (f-seq (f-or floatnumber integer) (f-reg "[jJ]"))))
(define imag
  (<p-lambda> (c)
    (.. (c) (imagnumber c))
    (<p-cc> (string->number (string-append "0+" c "i")))))

(define (mk-id S c cc) cc)

(define number
  (p-freeze 'number
    (f-or! imag float integer)
    mk-id))

(define symbol
  (let ()
    (define (__*__ i)
      (match (string->list i)
	((#\_ #\_ . l)
	 (match (reverse l)
	   ((#\_ #\_ . l) #t)
	   (_ #f)))
	(_ #f)))

    (define (__* i)
      (match (string->list i)
	((#\_ #\_ . l)
	 #t)
	(_ #f)))

    (define (_* i)
      (match (string->list i)
	((#\_  . l)
	 #t)
	(_ #f)))

    (<p-lambda> (c)
     (.. (i) (identifier_ c))
     (cond 
      ((__*__  i)
       (#:identifier i #:system))
      ((__*    i)
       (#:identifier i #:private))
      ((_*     i)
       (#:identifier i #:local))
      ((eq? i '_)
       (#:_))
      ((hash-ref keyw i)
       (#:keyword i))
      (else
       (#:identifier i))))))
       
(define identifier 
  (<p-lambda> (c)
     (.. (i) (identifier_ c))
     (when (not (eq? (car i) #:keyword))
        (<p-cc> c))))

;;;; +++++++++++++++++++++++++++++++++++++++++++++++ STRING +++++++++++++++
(define string-prefix     (mk-token (f-reg! "[ruRU]")))
(define short-string-char (f-not! (f-reg "[\n\"']")))
(define long-string-char  (f-not! "\n"))
(define string-esc        (f-seq (f-tag "\\") (f-reg! ".")))
(define short-string-item (f-or short-string-char string-esc))
(define long-string-item  (f-or long-string-char string-esc))
 
(define long-string
  (mk-token
   (f-or
    (f-seq! "'''"    (f* long-string-item) "'''")
    (f-seq! "\"\"\"" (f* long-string-item) "\"\"\""))))

(define short-string  
  (mk-token
   (f-or
    (f-seq! "'"  (f* short-string-item) "'")
    (f-seq! "\"" (f* short-string-item) "\""))))

(define string-literal 
  (p-freeze 'string-literal
    (<p-lambda> (c)
       (xx (pre) (<or>
		  (.. (string-prefix c))
		  (<p-cc> #f)))
       (.. (str) (f-or! long-string short-string))
       (<p-cc> (#:string pre str)))
    mk-id))

;; ++++++++++++++++++++++++++++++++++++++++++ BYTE ++++++++++++++++++++++++++

(define bytes-prefix  
  (mk-token
   (f-or!
    (f-seq! (f-tag! "b") (f-or f-true (f-reg! "[rR]")))
    (f-seq! (f-tag! "B") (f-or f-true (f-reg! "[rR]")))
    (f-seq! (f-tag! "r") (f-or f-true (f-reg! "[bB]")))
    (f-seq! (f-tag! "R") (f-or f-true (f-reg! "[bB]"))))))

(define bytes-esc     (f-seq "\\" (f-reg ".")))

(define short-bytes-char (f-not! (f-reg "[\\\n'\"]")))
(define long-bytes-char  (f-not! (f-reg "[\\]")))

(define short-bytes-item
  (f-or short-bytes-char bytes-esc))

(define long-bytes-item
  (f-or long-bytes-char bytes-esc))

(define short-bytes 
  (mk-token
   (f-or! (f-seq! "'"  (f* short-bytes-item) "'")
	  (f-seq! "\"" (f* short-bytes-item) " \""))))

(define long-bytes 
  (mk-token
   (f-or! (f-seq! "'''"    (f* long-bytes-item) "'''") 
	  (f-seq! "\"\"\"" (f* long-bytes-item) "\"\"\""))))

(define bytes-literal 
  (p-freeze 'string-literal
    (<p-lambda> (c)
       (.. (pre) (bytes-prefix c))
       (.. (str) ((f-or! long-bytes short-bytes) pre))
       (<p-cc> (#:bytes pre str)))
    mk-id))
    

; +++++++++++++++++++++++++++++++++++ PARSER SUBSECTION +++++++++++++++++   
(define stmt            #f)
(define testlist        #f)   
(define dotted_name     #f)
(define arglist         #f)
(define classdef        #f)
(define funcdef         #f)
(define test            #f)
(define small_stmt      #f)


(define expr_stmt       #f)
(define del_stmt        #f)
(define pass_stmt       #f)
(define flow_stmt       #f)
(define import_stmt     #f)
(define global_stmt     #f)
(define nonlocal_stmt   #f)
(define assert_stmt     #f)
(define testlist_star_expr   #f)
(define augassign       #f)
(define yield_expr      #f)
(define star_expr       #f)
(define exprlist        #f)
(define import_name     #f)
(define import_from     #f)
(define dotted_as_names #f)
(define import_as_names #f)
(define if_stmt         #f)
(define while_stmt      #f)
(define for_stmt        #f)
(define try_stmt        #f)
(define with_stmt       #f)
(define suite           #f)
(define except_clause   #f)
(define with_item       #f)
(define expr            #f)
(define or_test         #f)
(define lambdef         #f)
(define lambdef_nocond  #f)
(define and_test        #f)
(define not_test        #f)
(define comparison      #f)
(define comp_op         #f)
(define xor_expr        #f)
(define and_expr        #f)
(define or_expr         #f)
(define arith_expr      #f)
(define shift_expr      #f)
(define term            #f)
(define factor          #f)
(define power           #f)
(define atom            #f)
(define trailer         #f)
(define subscriptlist   #f)
(define testlist_comp   #f)
(define dictorsetmaker  #f)
(define comp_for        #f)
(define subscript       #f)
(define sliceop         #f)
(define argument        #f)
(define comp_if         #f)
(define yield_arg       #f)


(define file-input (f-seq (f* (f-or nl (f-seq indent= stmt))) f-eof))

(define eval-input (f-seq testlist (f* nl) f-eof))

(define decorator (f-cons (f-seq ws "@" ws dotted_name ws) 
			  (f-seq (ff? (f-seq "(" ws (ff? arglist) ws ")" ws))
				 f-nl)))

(define decorators (ff+ decorator))

(define decorated (f-list #:decorated
			  decorators 
			  (f-or classdef funcdef)))

(define FALSE (f-out #f))
(define tfpdef
  (f-cons (f-seq ws identifier ws) (f-or
				    (f-seq ":" ws test ws)
				    FALSE)))

(define vfpdef identifier)
(define mk-py-list
  (lambda (targlist tfpdef)
    (let* ((t       (f-or (f-seq "=" ws test ws) FALSE))
	   (arg     (f-list ws tfpdef ws t ws))
	   (arg..   (ff* (f-seq ws "," arg)))
	   (args    (f-cons arg arg..))
	   (arg*    (f-seq ws "*" ws (f-list tfpdef ws arg..)))
	   (arg**   (f-seq ws "**" tfpdef)))
      (f-cons
       (f-out targlist)
       (f-or
	(f-cons args 
		(f-or (f-list arg* (f-or arg** FALSE)) 
		      (f-list FALSE FALSE)))
	(f-list FALSE arg* (f-or arg** FALSE))
	(f-list FALSE FALSE arg**))))))

(define typedargslist (mk-py-list #:types-args-list tfpdef))
(define varargslist   (mk-py-list #:var-args-list   vfpdef))

(define parameters (f-seq! (f-tag "(") (f-or typedargslist
					     (f-out (list #f #f #f)))
			   (f-tag ")")))

(set! funcdef   
  (p-freeze 'funcdef
   (<p-lambda> (c)
     (.. (c)  ((f-tag "def") c))
     (.. (c)  (ws c))
     (.. (id) (identifier c))
     (.. (c)  (ws id))
     (.. (pa) (parameters c))
     (.. (c)  (ws pa))
     (.. (te) ((ff? (f-seq! ws "->" ws test)) c))
     (.. (su) (f-seq! ":" ws suite))
     (<p-cc> (list #:funcdef id pa te su)))
   mk-id))

(define simple_stmt (f-list #:stmt
			    (f-seq
			     (f-cons small_stmt
				     (ff* (f-seq ";" small_stmt)))
			     ws (f? ";") ws nl)))
(set! small_stmt
  (f-or expr_stmt del_stmt pass_stmt flow_stmt import_stmt global_stmt
	nonlocal_stmt assert_stmt))

(set! expr_stmt 
  (f-seq testlist_star_expr
	 (f-or
	  (f-seq augassign 
		 (f-or (f-or yield_expr testlist)
		       (f* (f-seq "=" 
				  (f-or yield_expr
					testlist_star_expr))))))))

(set! testlist_star_expr
  (f-cons (f-or test star_expr) 
	  (f-seq 
	   (ff* (f-seq "," (f-or test star_expr)))
	   (f? ","))))


(set! augassign
  (mk-token
   (f-seq
    ws
    (apply f-or!
	   (map f-tag
		'("+=" "-=" "*=" "/=" "%=" "&=" "|=" "^="
		  "<<=" ">>=" "**=" "//=")))
    ws)))

(set! del_stmt  (f-cons #:del (f-seq "del" exprlist)))

(set! pass_stmt (f-seq "pass" #:pass))

(set! flow_stmt 
  (f-or
   (f-seq "break"   #:break)
   (f-seq "coninue" #:continue)
   (f-cons #:return (f-seq "return" (ff? testlist)))
   yield_expr
   (f-cons #:raise  (f-seq "raise" 
			   (f-or (f-cons test
					 (ff?
					  (f-seq "from" test)))
				 (f-cons FALSE FALSE))))))

(set! import_stmt (f-or import_name import_from))

(set! import_name (f-seq "import" dotted_as_names))

(define dottir (mk-token (f-or! (f-tag! "...") (f-tag! "."))))
(define dots*  (ff* dottir))
(define dots+  (ff+ dottir))

(set! import_from
  (f-seq "from"
	 (f-cons
	  (f-or (f-cons dots* dotted_name) dots+)
	  (f-seq "import" (f-or "*"
				(f-seq "(" import_as_names ")")
				import_as_names)))))

(define import_as_name 
  (f-cons identifier (ff? (f-seq "as" identifier))))

(define dotted_as_name
  (f-cons dotted_name (ff? (f-seq "as" identifier))))

(set! import_as_names
  (f-seq
   (f-cons import_as_name (ff* (f-seq "," import_as_name)))
   (f? ",")))
  
(set! dotted_as_names
  (f-cons dotted_as_name (ff* (f-seq "," dotted_as_name))))

(set! dotted_name
  (f-cons identifier (ff* (f-seq "." identifier))))

(define comma_name
  (f-cons identifier (ff* (f-seq "," identifier))))

(set! global_stmt
  (f-cons #:global (f-seq "global" comma_name)))

(set! nonlocal_stmt
  (f-cons #:nonlocal (f-seq "nonlocal" comma_name)))

(set! assert_stmt
  (f-cons #:assert
	  (f-seq "assert" (f-cons test (ff* (f-seq  "," test))))))


(define compound_stmt
  (f-or! if_stmt while_stmt for_stmt try_stmt with_stmt funcdef classdef 
	 decorated))

(define single_input (f-or (f-seq (f-pk 0) nl)
			   (f-seq (f-pk 1) indent= simple_stmt) 
			   (f-seq (f-pk 2) indent= compound_stmt nl)))

(set! stmt (f-or simple_stmt compound_stmt))

(set! if_stmt
  (f-cons 
   #:if
   (f-seq 
    "if"
    (f-cons test
	    (f-seq ":"
		   (f-cons suite
			   (f-cons
			    (ff+ (f-seq "elif"
					(f-cons test
						(f-seq ":" suite))))
			    (ff? (f-seq "else" ":" suite)))))))))

(set! while_stmt
  (f-cons 
   #:while
   (f-seq "while"
	  (f-cons test
		  (f-seq ":"
			 (f-cons suite
				 (ff? (f-seq "else" ":" suite))))))))

(set! for_stmt
  (f-cons 
   #:for
   (f-seq "for"
	  (f-cons exprlist
	     (f-seq "in"
		    (f-cons testlist
		       (f-cons (f-seq ":" suite)
			       (ff? (f-seq "else" ":" suite)))))))))

(set! try_stmt
  (f-cons
   #:try
   (f-seq ws "try" ":"
	  (f-cons suite
		  (f-or
		   (f-cons
		    (ff+ (f-seq except_clause ":" suite))
		    (f-cons
		     (ff? (f-seq "else" ":" suite))
		     (ff? (f-seq "finally" ":" ws suite))))
		   (f-cons
		    FALSE
		    (f-cons
		     FALSE
		     (f-seq "finally" ":" suite))))))))

(set! with_stmt
  (f-cons
   #:with
   (f-seq "with"
	  (f-cons
	   (f-cons with_item
		   (ff* (f-seq "," with_item)))
	   (f-seq ":" suite)))))

(set! with_item
  (f-cons test (f-seq "as" expr)))

(set! except_clause
  (f-seq "except"
	 (ff? (f-cons test (ff? (f-seq "as" identifier))))))

(set! suite  
  (f-cons #:suite
	  (f-or (f-list simple_stmt)
		(f-seq nl indent+
		       (f-cons stmt
			       (ff* (f-seq indent= stmt)))
		       indent-))))

(set! test
  (f-or
   (f-cons #:if
	   (f-cons (f-seq "if"   or_test)
		   (f-seq "else" test)))
   lambdef
   (f-cons (f-out #f)
	   (f-cons or_test FALSE))))


(define test_nocond
  (f-or or_test lambdef_nocond))

(set! lambdef
  (f-cons
   #:lambdef
   (f-cons (f-seq "lambda" (ff? varargslist '()))
	   (f-seq ":" test))))
(set! lambdef_nocond
  (f-cons
   #:lambdef
   (f-cons (f-seq "lambda" (ff? varargslist '()))
	   (f-seq ":" test_nocond))))

(set! or_test
  (f-or! (f-cons #:or (f-cons and_test (ff+ (f-seq "or" and_test))))
	 and_test))

(set! and_test
  (f-or! (f-cons #:and (f-cons not_test (ff* (f-seq "and" not_test))))
	 not_test))

(set! not_test
  (f-or!
   (f-cons #:not (f-seq "not" not_test))
   comparison))

(set! comparison
  (f-or!
   (f-cons #:comp
	   (f-cons expr
		   (ff+ (f-cons comp_op expr))))
   expr))

(set! comp_op
  (f-or! 
   (f-seq (f-seq "not" "in" ) (f-out "notin"))
   (f-seq (f-seq "is"  "not") (f-out "isnot"))
   (apply f-or!
	  (map (lambda (x) (f-seq x (f-out x)))
	       '("<" ">" "==" ">=" "<=" "<>" "!=" "in" "is")))))
			  

(set! star_expr (f-cons #:starexpr (f-seq "*" expr)))
(set! expr
  (f-or!
   (f-cons #:bxor (f-cons xor_expr (ff+ (f-seq "|" xor_expr))))
   xor_expr))
(set! xor_expr
  (f-or!
   (f-cons #:band (f-cons and_expr (ff+ (f-seq "^" and_expr))))
   and_expr))

(set! and_expr
  (f-or!
   (f-cons #:band (f-cons shift_expr (ff+ (f-seq "&" shift_expr))))
   shift_expr))

(set! shift_expr
  (f-or!
   (f-cons #:<< (f-cons arith_expr (ff+ (f-seq "<<" arith_expr))))
   (f-cons #:>> (f-cons arith_expr (ff+ (f-seq ">>" arith_expr))))
   arith_expr))

(set! arith_expr
  (f-or!
   (f-cons #:+ (f-cons term (ff+ (f-seq "+" term))))
   (f-cons #:- (f-cons term (ff+ (f-seq "-" term))))
   term))

(set! term
  (f-or!
   (f-cons #:*  (f-cons factor (ff+ (f-seq "*"  factor))))
   (f-cons #:// (f-cons factor (ff+ (f-seq "//" factor))))
   (f-cons #:/  (f-cons factor (ff+ (f-seq "/"  factor))))
   (f-cons #:%  (f-cons factor (ff+ (f-seq "%"  factor))))
   factor))


(set! factor
  (f-or!
   (f-cons #:u+ (f-seq "+" factor))
   (f-cons #:u- (f-seq "-" factor))
   (f-cons #:u~ (f-seq "~" factor))
   power))

(set! power
  (f-cons #:power 
     (f-cons atom 
	(f-cons (ff* trailer)
		(f-or! (f-seq "**" factor)
		       FALSE)))))

(set! trailer
  (f-or!
   (f-seq "(" (ff? arglist) ")")
   (f-seq "[" subscriptlist "]")
   (f-seq "." identifier)))

(set! atom
  (f-or!
   (f-cons
    #:subexpr
    (f-seq "(" ff? (f-or! yield_expr testlist_comp) ")"))
   (f-cons
    #:list
    (f-seq "[" (ff? testlist_comp) ")"))
   (f-cons
    #:dict
    (f-seq "{" (ff? dictorsetmaker) "}"))
   identifier
   number
   (f-cons #:string  (ff+ string))
   (f-cons #:...     "...")
   (f-cons #:None    "None")
   (f-cons #:True    "True")
   (f-cons #:false   "False")))

(set! testlist_comp
  (f-cons
   (f-or! star_expr test)
   (f-or!
    comp_for
    (f-seq (ff* (f-seq "," (f-or! star_expr test)))
	   (f? ",")))))

(set! subscriptlist
  (f-cons
   subscript
   (f-seq (ff* (f-seq "," subscript)) (f? ","))))

(set! subscript
  (f-or!
   (f-list (ff? test) ":" (ff? test) (ff? sliceop))
   (f-list test FALSE FALSE)))

(set! sliceop
  (f-seq ":" (ff? test)))

(define exprlist
  (let ((f (f-or expr star_expr)))
    (f-cons f (f-seq (ff* (f-seq "," f)) (f? ",")))))

(set! testlist
  (f-cons
   test
   (f-seq (ff* "," test) (f? ","))))
				
(set! dictorsetmaker
  (let ((f (f-cons test (f-seq ":" test))))
    (f-or!
     (f-cons* f    (f-seq (ff* (f-seq "," f)) (f? ",")))
     (f-cons  f    comp_for)
     (f-cons  test comp_for)
     (f-cons  test (f-seq (ff* (f-seq "," test)) (f? ","))))))

(set! classdef
  (f-list
   #:classdef
   (f-seq "class" identifier)
   (ff? (f-seq "(" (ff? arglist '()) ")"))
   (f-seq ":" suite)))
      
(set! arglist
  (f-or!
   (f-list (f-seq (ff+ (f-seq argument ",")) (f? ","))
	   FALSE FALSE)
   (f-list (f-seq (ff* (f-seq argument ",")))
	   FALSE
	   (ff? (f-seq "**" test)))
   (f-list (f-seq (ff* (f-seq argument ",")))
	   (f-seq "*" (f-cons test (ff* (f-seq "," argument))))
	   (ff? (f-seq "," "**" test)))))
   
(set! argument
  (f-or!
   (f-list #:=    test (f-seq "=" test))
   (f-list #:comp test (ff? comp_for))))

(define comp_iter (f-or! comp_for comp_if))
(define comp_for  (f-list (f-seq "for" exprlist)
			  (f-seq "in"  or_test)
			  (ff? comp_iter)))
(set! comp_if   (f-list (f-seq "if" test_nocond)
			  (ff? comp_iter)))

(set! yield_expr
  (f-list #:yield (f-seq "yield" (ff? yield_arg))))

(set! yield_arg
  (f-or!
   (f-list #:from (f-seq "from" test))
   (f-list #:list testlist)))


(define (p str)
  (pp (parse str single_input))
  (if #f #f))