path: root/modules/language/python/parser.scm

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

(define do-print #f)
(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 ppp
  (case-lambda
    ((s x)
     (pretty-print `(,s ,(syntax->datum x)))
     x)
    ((x)
     (pretty-print (syntax->datum x))
     x)))

(define-syntax-rule (Ds f) (lambda x (apply f x)))
(define-syntax-rule (DDs op f ...) (op (lambda x (apply f x)) ...))

(define  divide truncate/)
;; +++++++++++++++++++++++++++++++++++++ SCANNER SUBSECTION
(define nl (f-or f-nl f-eof))
(define com (f-seq "#" (f* (f-not f-nl)) 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 (wn_ n i)
  (<p-lambda> (c)
     (cond
       ((> i n) <fail>)
       ((= i n)
        (.. ((f-and (f-not w) f-true) 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)
    (<pp> `(,n ,i))
    (<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)))
     (<and!>
      (when (> i n))
      (<with-bind> ((INDENT (cons i INDENT)))
        (<p-cc> c))))))

(define wn+
  (<p-lambda> (c)
    (<let> ((n (car INDENT)))
      (.. ((wn+_ n 0) c)))))

(define wn
  (<p-lambda> (c)
    (<let> ((n (car INDENT)))
      (.. ((wn_ n 0) c)))))

(define indent= wn)
(define indent+ wn+)
(define indent-
  (<p-lambda> (c)              
    (<with-bind> ((INDENT (cdr INDENT)))
      (<p-cc> c))))

(define identifier__ 
  (let ()
    (define ih  (f-reg! "[a-zA-Z_]"))
    (define i.. (f-or! 'or ih (f-reg! "[0-9]")))
    (mk-token
     (f-seq ih (f* i..)))))

(define keyw (make-hash-table))
(for-each
 (lambda (x) (hash-set! keyw (symbol->string 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
                 (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 identifier_
  (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)
       (<p-cc> `(#:identifier ,i #:system)))
      ((__*    i)
       (<p-cc> `(#:identifier ,i #:private)))
      ((_*     i)
       (<p-cc> `(#:identifier ,i #:local)))
      ((eq? i '_)
       (<p-cc> #:_))
      ((hash-ref keyw i)
       (<p-cc> `(#:keyword ,i)))
      (else
       (<p-cc> `(#:identifier ,i)))))))
       
(define identifier 
  (<p-lambda> (c)
     (.. (i) (identifier_ c))
     (if (not (eq? (car i) #:keyword))
         (<p-cc> i)
         <fail>)))

;;;; +++++++++++++++++++++++++++++++++++++++++++++++ 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 
  (p-freeze 'string-literal
    (f-list #:string
            (ff? string-prefix)
            (f-or! long-string short-string))
    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 dottaed_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 dotted_name     #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 (Ds dotted_name) ws) 
			  (f-seq (ff? (f-seq "(" ws (ff? (Ds 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 identifier (f-or
                      (f-seq ":" ws test ws)
                      FALSE)))

(define vfpdef identifier)
(define mk-py-list
  (lambda (targlist tfpdef)
    (let* ((t       (f-or (f-seq "=" (Ds test)) FALSE))
	   (arg     (f-list tfpdef t))
	   (arg..   (ff* (f-seq "," arg)))
	   (args    (f-cons arg arg..))
	   (arg*    (f-seq "*" (f-list tfpdef arg..)))
	   (arg**   (f-seq "**" tfpdef)))
      (f-cons
       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**)
        (f-list 'a1 '() FALSE FALSE))))))

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

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

(set! funcdef   
  (p-freeze 'funcdef
    (f-list 'fundef
           #:def 
           (f-seq "def" identifier)
           parameters
           (ff? (f-seq! "->" (Ds test)))
           (f-seq ":" (Ds suite)))
    mk-id))

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

(set! expr_stmt 
 (f-list 'expr_stmt
   #:expr-stmt
   (Ds testlist_star_expr)
   (f-or!
    (f-list 'augassign #:augassign
            (Ds augassign)
            (f-or (Ds yield_expr) (Ds testlist)))
    (f-cons 'assign #:assign
       (ff* (f-seq "=" 
                   (f-or (Ds yield_expr)
                         (Ds testlist_star_expr))))))))

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


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

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

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

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

(set! import_name (f-seq "import" dotted_as_names))
(set! import_stmt (f-list #:import
                          (f-or 'import_stmt import_name (Ds import_from))))



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

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

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

(define dotted_as_name
  (f-cons (Ds 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 #:global (f-seq "global" comma_name)))

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

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


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

(define single_input (f-or! (f-seq indent= simple_stmt) 
                            (f-seq indent= compound_stmt nl)
                            (f-seq (f-or nl f-eof))))

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

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

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

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

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

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

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


(set! except_clause
  (f-seq 'except "except"
	 (ff? (f-cons (Ds 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! 'test
    (f-list #:test
            (Ds or_test)           
            (ff? (f-list 
                  (f-seq "if" (Ds or_test))
                  (f-seq "else" test))))
    (Ds lambdef)))

(define test_nocond
  (f-or 'nocond (Ds or_test) (Ds lambdef_nocond)))

(set! lambdef
  (f-list 'lambdef
   #:lambdef
   (f-seq "lambda" (ff? (Ds varargslist) '()))
   (f-seq ":" (Ds test))))

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

(set! or_test
  (p-freeze 'or_test
    (f-or! 'or_test
      (f-cons #:or (f-cons (Ds and_test) (ff+ (f-seq "or" (Ds and_test)))))
      (Ds and_test))
    mk-id))

(set! and_test
  (p-freeze 'and_test
    (f-or! 'and_test
     (f-cons #:and (f-cons (Ds not_test) (ff+ (f-seq "and" (Ds not_test)))))
     (Ds not_test))
    mk-id))

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

(set! comparison
  (p-freeze 'comparison
    (f-or! 'comparison
      (f-cons #:comp
              (f-cons (Ds expr)
                      (ff+ (f-cons (Ds comp_op) (Ds expr)))))
      (Ds expr))
    mk-id))

(set! comp_op
  (f-or! 'comp_op
   (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 'star_expr #:starexpr (f-seq "*" (Ds expr))))
(set! expr
  (p-freeze 'expr
    (f-or! 'expr
     (f-cons #:bor (f-cons (Ds xor_expr) (ff+ (f-seq "|" (Ds xor_expr)))))
     (Ds xor_expr))
    mk-id))

(set! xor_expr
 (p-freeze 'xor
   (f-or! 'xor
     (f-cons #:bxor (f-cons (Ds and_expr) (ff+ (f-seq "^" (Ds and_expr)))))
     (Ds and_expr))
   mk-id))

(set! and_expr
  (p-freeze 'and
    (f-or! 'and
           (f-cons #:band (f-cons (Ds shift_expr) 
                                  (ff+ (f-seq "&" (Ds shift_expr)))))
           (Ds shift_expr))
    mk-id))

(set! shift_expr
  (p-freeze 'shift
    (f-or! 'shift
     (f-cons #:<< (f-cons (Ds arith_expr) (ff+ (f-seq "<<" (Ds arith_expr) ))))
     (f-cons #:>> (f-cons (Ds arith_expr) (ff+ (f-seq ">>" (Ds arith_expr) ))))
     (Ds arith_expr))
    mk-id))

(set! arith_expr
  (p-freeze 'arith
    (f-or! 'arith
      (f-cons #:+ (f-cons (Ds term) (ff+ (f-seq 'rest "+" (Ds term) ))))
      (f-cons #:- (f-cons (Ds term) (ff+ (f-seq "-" (Ds term) ))))
      (f-seq 'single_term (Ds term)))
    mk-id))

(set! term
  (p-freeze 'term
    (f-or! 'term
           (f-cons #:*  (f-cons (Ds factor) (ff+ (f-seq "*"  (Ds factor) ))))
           (f-cons #:// (f-cons (Ds factor) (ff+ (f-seq "//" (Ds factor) ))))
           (f-cons #:/  (f-cons (Ds factor) (ff+ (f-seq "/"  (Ds factor) ))))
           (f-cons #:%  (f-cons (Ds factor) (ff+ (f-seq "%"  (Ds factor) ))))
           (f-seq 'single-factor (Ds factor)))
    mk-id))


(set! factor
  (p-freeze 'factor
    (f-or! 'factor
      (f-cons #:u+ (f-seq "+" factor))
      (f-cons #:u- (f-seq "-" factor))
      (f-cons #:u~ (f-seq "~" factor))
      (Ds power))
    mk-id))

(set! power
  (p-freeze 'power            
    (f-cons 'power #:power                    
       (f-cons (f-or (f-list #:f (Ds identifier) ":" (Ds atom)) (Ds atom)) 
   	  (f-cons (ff* (Ds trailer))
                  (f-or! (f-seq "**" factor)
                         FALSE))))
    mk-id))

(set! trailer
  (f-or! 'trailer
   (f-seq "(" (ff? (Ds arglist)) ")")
   (f-seq "[" (Ds subscriptlist) "]")
   (f-seq (f-list #:dot (ff+ "." identifier))))

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

(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* 'subscriptlist
   #:subscripts
   (Ds subscript)
   (f-seq (ff* (f-seq "," (Ds  subscript))) (f? ","))))

(set! subscript 
  (f-or! 'subscript
   (f-list (ff? test '()) (f-seq ":" (ff? test '())) (ff? (Ds 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* (f-seq "," 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    (Ds comp_for))
     (f-cons  test (Ds 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? (Ds arglist) '()) ")"))
   (f-seq ":" suite)))
      
(set! arglist
  (f-or! 'arglist
   (f-list 'arg0
           #:arglist
           (f-seq (ff* (f-seq (Ds argument) ",")))
	   (f-seq "*" (f-cons test (ff* (f-seq "," (Ds argument)))))
	   (ff? (f-seq "," "**" test)))

   (f-list 'arg1
           #:arglist
           (f-seq (ff* (f-seq (Ds argument) ",")))
	   FALSE
	   (f-seq "**" test))

   (f-list 'arg2
           #:arglist
           (f-seq (f-append (ff* (f-seq (Ds argument) ",")) 
                            (f-seq (Ds argument) (f? ","))))
	   FALSE FALSE)))
   
(set! argument
  (f-or!
   (f-list #:=    test (f-seq "=" test))
   (f-list #:comp test (ff? (Ds comp_for)))))

(define comp_iter (f-or! (Ds comp_for) (Ds 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? (Ds yield_arg)))))

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


(define input (f-seq
               (ff+ (f-seq (f? ws)
                           (f-or! (f-seq indent= simple_stmt) 
                                  (f-seq indent= compound_stmt nl))))
               
               (f-seq (f? ws) (f-or nl f-eof))))

(define (p str)
  (with-fluids ((*whitespace* (f* (f-reg "[ \t\r]"))))
    (parse str input)))

(define (python-parser . l)
  (with-fluids ((*whitespace* (f* (f-reg "[ \t\r]"))))
    (ppp (apply parse (append l (list (f-seq nl ws single_input ws)))))))