;;----------------------------------------------------------------------
;; quasiquote, and, or

(module qq-and-or '#%kernel
  (#%require (for-syntax "stx.rkt" '#%kernel))
  
  (define-syntaxes (let let* letrec)
    (let-values ([(lambda-stx) (quote-syntax lambda-stx)]
                 [(letrec-values-stx) (quote-syntax letrec-values)])
      (let-values ([(go)
                    (lambda (stx named? star? target)
                      (define-values (stx-cadr) (lambda (x) (stx-car (stx-cdr x))))
                      (define-values (id-in-list?)
                        (lambda (id l)
                          (if (null? l)
                              #f
                              (if (bound-identifier=? id (car l)) 
                                  #t
                                  (id-in-list? id (cdr l))))))
                      (define-values (stx-2list?)
                        (lambda (x)
                          (if (stx-pair? x)
                              (if (stx-pair? (stx-cdr x))
                                  (stx-null? (stx-cdr (stx-cdr x)))
                                  #f)
                              #f)))
                      (if (if (not (stx-list? stx))
                              #t
                              (let-values ([(tail1) (stx-cdr stx)])
                                (if (stx-null? tail1)
                                    #t
                                    (if (stx-null? (stx-cdr tail1))
                                        #t
                                        (if named?
                                            (if (symbol? (syntax-e (stx-car tail1)))
                                                (stx-null? (stx-cdr (stx-cdr tail1)))
                                                #f)
                                            #f)))))
                          (raise-syntax-error #f "bad syntax" stx)
                          (void))
                      (let-values ([(name) (if named?
                                               (let-values ([(n) (stx-cadr stx)])
                                                 (if (symbol? (syntax-e n))
                                                     n
                                                     #f))
                                               #f)])
                        (let-values ([(bindings) (stx->list (stx-cadr (if name
                                                                          (stx-cdr stx)
                                                                          stx)))]
                                     [(body) (stx-cdr (stx-cdr (if name
                                                                   (stx-cdr stx)
                                                                   stx)))])
                          (if (not bindings)
                              (raise-syntax-error 
                               #f 
                               "bad syntax (not a sequence of identifier--expression bindings)" 
                               stx
                               (stx-cadr stx))
                              (let-values ([(new-bindings)
                                            (letrec-values ([(loop)
                                                             (lambda (l)
                                                               (if (null? l)
                                                                   null
                                                                   (let-values ([(binding) (car l)])
                                                                     (cons
                                                                      (if (stx-2list? binding)
                                                                          (if (symbol? (syntax-e (stx-car binding)))
                                                                              (if name
                                                                                  (cons (stx-car binding)
                                                                                        (stx-cadr binding))
                                                                                  (datum->syntax
                                                                                   lambda-stx
                                                                                   (cons (cons (stx-car binding)
                                                                                               null)
                                                                                         (stx-cdr binding))
                                                                                   binding))
                                                                              (raise-syntax-error 
                                                                               #f 
                                                                               "bad syntax (not an identifier)" 
                                                                               stx
                                                                               (stx-car binding)))
                                                                          (raise-syntax-error 
                                                                           #f 
                                                                           "bad syntax (not an identifier and expression for a binding)" 
                                                                           stx
                                                                           binding))
                                                                      (loop (cdr l))))))])
                                              (loop bindings))])
                                (if star?
                                    (void)
                                    (if ((length new-bindings) . > . 5)
                                        (let-values ([(ht) (make-hasheq)])
                                          (letrec-values ([(check) (lambda (l)
                                                                     (if (null? l)
                                                                         (void)
                                                                         (let*-values ([(id) (if name
                                                                                                 (caar l)
                                                                                                 (stx-car (stx-car (car l))))]
                                                                                       [(idl) (hash-ref ht (syntax-e id) null)])
                                                                           (if (id-in-list? id idl)
                                                                               (raise-syntax-error
                                                                                #f
                                                                                "duplicate identifier"
                                                                                stx
                                                                                id)
                                                                               (begin
                                                                                 (hash-set! ht (syntax-e id) (cons id idl))
                                                                                 (check (cdr l)))))))])
                                            (check new-bindings)))
                                        (letrec-values ([(check) (lambda (l accum)
                                                                   (if (null? l)
                                                                       (void)
                                                                       (let-values ([(id) (if name
                                                                                              (caar l)
                                                                                              (stx-car (stx-car (car l))))])
                                                                         (if (id-in-list? id accum)
                                                                             (raise-syntax-error
                                                                              #f
                                                                              "duplicate identifier"
                                                                              stx
                                                                              id)
                                                                             (check (cdr l) (cons id accum))))))])
                                          (check new-bindings null))))
                                (datum->syntax
                                 lambda-stx
                                 (if name
                                     (apply list
                                            (list 
                                             (quote-syntax letrec-values)
                                             (list
                                              (list
                                               (list name)
                                               (list* (quote-syntax lambda)
                                                      (apply list (map car new-bindings))
                                                      body)))
                                             name)
                                            (map cdr new-bindings))
                                     (list* target
                                            new-bindings
                                            body))
                                 stx))))))])
        (values
         (lambda (stx) (go stx #t #f (quote-syntax let-values)))
         (lambda (stx) (go stx #f #t (quote-syntax let*-values)))
         (lambda (stx) (go stx #f #f (quote-syntax letrec-values)))))))

  (define-values (qq-append)
    (lambda (a b)
      (if (list? a)
	  (append a b)
	  (raise-type-error 'unquote-splicing "proper list" a))))

  (define-syntaxes (quasiquote)
    (let-values ([(here) (quote-syntax here)] ; id with module bindings, but not lexical
                 [(unquote-stx) (quote-syntax unquote)]
                 [(unquote-splicing-stx) (quote-syntax unquote-splicing)])
      (lambda (in-form)
	(if (identifier? in-form)
	    (raise-syntax-error #f "bad syntax" in-form)
            (void))
	(let-values
	    (((form) (if (stx-pair? (stx-cdr in-form))
			 (if (stx-null? (stx-cdr (stx-cdr in-form)))
			     (stx-car (stx-cdr in-form))
			     (raise-syntax-error #f "bad syntax" in-form))
			 (raise-syntax-error #f "bad syntax" in-form)))
	     ((normal)
	      (lambda (x old)
		(if (eq? x old)
		    (if (stx-null? x) 
			(quote-syntax ())
			(list (quote-syntax quote) x))
		    x)))
	     ((apply-cons)
	      (lambda (a d)
		(if (stx-null? d)
		    (list (quote-syntax list) a)
		    (if (if (pair? d)
			    (if (free-identifier=? (quote-syntax list) (car d))
				#t
				(free-identifier=? (quote-syntax list*) (car d)))
			    #f)
			(list* (car d) a (cdr d))
			(list (quote-syntax list*) a d))))))
	  (datum->syntax
	   here
	   (normal
	    (letrec-values
		(((qq)
		  (lambda (x level)
		    (let-values
			(((qq-list)
			  (lambda (x level)
			    (let-values
				(((old-first) (stx-car x)))
			      (let-values
				  (((old-second) (stx-cdr x)))
				(let-values
				    (((first) (qq old-first level)))
				  (let-values
				      (((second) (qq old-second level)))
				    (let-values
					()
				      (if (if (eq? first old-first)
					      (eq? second old-second)
					      #f)
					  x
					  (apply-cons
					   (normal first old-first)
					   (normal second old-second)))))))))))
		      (if (stx-pair? x)
			  (let-values
			      (((first) (stx-car x)))
			    (if (if (if (identifier? first)
					(free-identifier=? first unquote-stx)
					#f)
				    (stx-list? x)
				    #f)
				(let-values
				    (((rest) (stx-cdr x)))
				  (if (let-values
					  (((g35) (not (stx-pair? rest))))
					(if g35 g35 (not (stx-null? (stx-cdr rest)))))
				      (raise-syntax-error
				       'unquote
				       "expects exactly one expression"
				       in-form
				       x)
                                      (void))
				  (if (zero? level)
				      (stx-car rest)
				      (qq-list x (sub1 level))))
				(if (if (if (identifier? first)
					    (free-identifier=? first (quote-syntax quasiquote))
					    #f)
					(stx-list? x)
					#f)
				    (qq-list x (add1 level))
				    (if (if (if (identifier? first)
						(free-identifier=? first unquote-splicing-stx)
						#f)
					    (stx-list? x)
					    #f)
					(raise-syntax-error
					 'unquote-splicing
					 "invalid context within quasiquote"
					 in-form
					 x)
					(if (if (stx-pair? first)
						(if (identifier? (stx-car first))
						    (if (free-identifier=? (stx-car first)
                                                                           unquote-splicing-stx)
							(stx-list? first)
							#F)
						    #f)
						#f)
					    (let-values
						(((rest) (stx-cdr first)))
					      (if (let-values
						      (((g34) (not (stx-pair? rest))))
						    (if g34
							g34
							(not (stx-null? (stx-cdr rest)))))
						  (raise-syntax-error
						   'unquote
						   "expects exactly one expression"
						   in-form
						   x)
                                                  (void))
					      (let-values
						  (((uqsd) (stx-car rest))
						   ((old-l) (stx-cdr x))
						   ((l) (qq (stx-cdr x) level)))
						(if (zero? level)
						    (let-values
							(((l) (normal l old-l)))
                                                      (if (stx-null? l)
                                                          uqsd
                                                          (list (quote-syntax qq-append)
                                                                uqsd l)))
						    (let-values
							(((restx) (qq-list rest (sub1 level))))
						      (let-values
							  ()
							(if (if (eq? l old-l)
								(eq? restx rest)
								#f)
							    x
							    (apply-cons
							     (apply-cons
							      (quote-syntax (quote unquote-splicing))
							      (normal restx rest))
							     (normal l old-l))))))))
					    (qq-list x level))))))
			  (if (if (syntax? x) 
				  (vector? (syntax-e x))
				  #f)
			      (let-values
				  (((l) (vector->list (syntax-e x))))
                                ;; special case: disallow #(unquote <e>)
                                (if (stx-pair? l)
                                    (let-values ([(first) (stx-car l)])
                                      (if (identifier? first)
                                          (if (free-identifier=? first unquote-stx)
                                              (raise-syntax-error
                                               'unquote
                                               "invalid context within quasiquote"
                                               in-form
                                               first)
                                              (void))
                                          (void)))
                                    (void))
				(let-values
				    (((l2) (qq l level)))
                                  (if (eq? l l2)
                                      x
                                      (list (quote-syntax list->vector) l2))))
			      (if (if (syntax? x) (box? (syntax-e x)) #f)
				  (let-values
				      (((v) (unbox (syntax-e x))))
				    (let-values
					(((qv) (qq v level)))
				      (if (eq? v qv)
                                          x
                                          (list (quote-syntax box) qv))))
                                  (if (if (syntax? x) 
                                          (if (struct? (syntax-e x)) 
                                              (prefab-struct-key (syntax-e x))
                                              #f)
                                          #f)
                                      ;; pre-fab struct
                                      (let-values
                                          (((l) (cdr (vector->list (struct->vector (syntax-e x))))))
                                        (let-values
                                            (((l2) (qq l level)))
                                          (if (eq? l l2)
                                              x
                                              (list (quote-syntax apply)
                                                    (quote-syntax make-prefab-struct)
                                                    (list (quote-syntax quote)
                                                          (prefab-struct-key (syntax-e x)))
                                                    l2))))
                                      ;; hash[eq[v]]
                                      (if (if (syntax? x)
                                              (hash? (syntax-e x))
                                              #f)
                                          (letrec-values
                                              (((qq-hash-assocs)
						(lambda (x level)
						  (if (null? x)
						      x
						      (let-values
						          (((pair) (car x)))
                                                        (let-values ([(val)
                                                                      (qq (datum->syntax here (cdr pair)) level)]
                                                                     [(rest)
                                                                      (qq-hash-assocs (cdr x) level)])
                                                          (if (if (eq? val (cdr pair))
                                                                  (eq? rest (cdr x))
                                                                  #f)
                                                              x
                                                              (apply-cons
                                                               (list (quote-syntax list*)
                                                                     (list (quote-syntax quote)
                                                                           (datum->syntax here (car pair)))
                                                                     (if (eq? val (cdr pair))
                                                                         (list (quote-syntax quote)
                                                                               val)
                                                                         val))
                                                               (if (eq? rest (cdr x))
                                                                   (list (quote-syntax quote)
                                                                         rest)
                                                                   rest)))))))))
                                            (let-values (((l0) (hash-map (syntax-e x) cons)))
                                              (let-values
                                                  (((l) (qq-hash-assocs l0 level)))
                                                (if (eq? l0 l)
                                                    x
                                                    (list (if (hash-eq? (syntax-e x))
                                                              (quote-syntax make-immutable-hasheq)
                                                              (if (hash-eqv? (syntax-e x))
                                                                  (quote-syntax make-immutable-hasheqv)
                                                                  (quote-syntax make-immutable-hash)))
                                                          l)))))
                                          x)))))))))
	      (qq form 0))
	    form)
	   in-form)))))

  (define-syntaxes (and)
    (let-values ([(here) (quote-syntax here)])
      (lambda (x)
	(if (not (stx-list? x))
	    (raise-syntax-error #f "bad syntax" x)
            (void))
	(let-values ([(e) (stx-cdr x)])
	  (if (stx-null? e)
	      (quote-syntax #t)
	      (if (if (stx-pair? e)
		      (stx-null? (stx-cdr e))
		      #t)
                  (datum->syntax
                   here
                   (list (quote-syntax #%expression)
                         (stx-car e))
                   x)
		  (datum->syntax
		   here
		   (list (quote-syntax if)
			 (stx-car e)
			 (cons (quote-syntax and)
			       (stx-cdr e))
			 (quote-syntax #f))
		   x)))))))

  (define-syntaxes (or)
    (let-values ([(here) (quote-syntax here)])
      (lambda (x)
	(if (identifier? x)
	    (raise-syntax-error #f "bad syntax" x)
            (void))
	(let-values ([(e) (stx-cdr x)])
	  (if (stx-null? e) 
	      (quote-syntax #f)
	      (if (if (stx-pair? e)
		      (stx-null? (stx-cdr e))
		      #f)
                  (datum->syntax
                   here
                   (list (quote-syntax #%expression)
                         (stx-car e))
                   x)
		  (if (stx-list? e)
		      (let-values ([(tmp) 'or-part])
			(datum->syntax
			 here
			 (list (quote-syntax let) (list
						   (list
						    tmp
						    (stx-car e)))
			       (list (quote-syntax if)
				     tmp
				     tmp
				     (cons (quote-syntax or)
					   (stx-cdr e))))
			 x))
		      (raise-syntax-error 
		       #f
		       "bad syntax"
		       x))))))))

  (#%provide let let* letrec
             quasiquote and or))