(module etc mzscheme
  
  (require "spidey.ss"
           (lib "plthome.ss" "setup"))
  
  (require-for-syntax (lib "kerncase.ss" "syntax")
		      (lib "stx.ss" "syntax")
		      (lib "name.ss" "syntax")
		      (lib "context.ss" "syntax")
                      (lib "plthome.ss" "setup")
                      "list.ss"
                      "private/stxset.ss")

  
  (provide true false
	   boolean=? symbol=?
	   identity
	   compose
	   
	   build-string
	   build-vector
	   build-list
	   
	   loop-until
	   
           opt-lambda
           
	   local
	   recur
	   rec
	   evcase
	   nor
	   nand
	   let+

	   namespace-defined?
	   this-expression-source-directory
           this-expression-file-name
	   define-syntax-set
           
           hash-table

	   begin-with-definitions

	   begin-lifted)
  
  (define true #t)
  (define false #f)
  
  (define identity (polymorphic (lambda (x) x)))
  
  (define compose
    (polymorphic
     (case-lambda 
      [(f) (if (procedure? f) f (raise-type-error 'compose "procedure" f))]
      [(f g)
       (let ([f (compose f)]
             [g (compose g)])
         (if (eqv? 1 (procedure-arity f)) ; optimize: don't use call-w-values
             (if (eqv? 1 (procedure-arity g)) ; optimize: single arity everywhere
                 (lambda (x) (f (g x)))
                 (lambda args (f (apply g args))))
             (if (eqv? 1 (procedure-arity g)) ; optimize: single input
                 (lambda (a)
                   (call-with-values
                    (lambda () (g a))
                    f))
                 (lambda args
                   (call-with-values
                    (lambda () (apply g args))
                    f)))))]
      [(f . more)
       (let ([m (apply compose more)])
         (compose f m))])))
  

  (define  build-string
    (lambda  (n  fcn)
      (unless  (and (integer? n) (exact? n) (>= n 0))
        (error  'build-string  "~s must be an exact integer >= 0"  n))
      (unless  (procedure? fcn)
        (error  'build-string  "~s must be a procedure"  fcn))
      (let  ((str  (make-string n)))
        (let  loop  ((i  0))
          (if (= i n)  
              str
              (begin
                (string-set!  str  i  (fcn i))
                (loop  (add1 i))))))))
  
  ;; (build-vector n f) returns a vector 0..n-1 where the ith element is (f i).
  ;; The eval order is guaranteed to be: 0, 1, 2, ..., n-1.
  ;; eg: (build-vector 4 (lambda (i) i)) ==> #4(0 1 2 3)
  
  (define  build-vector
    (polymorphic
     (lambda  (n  fcn)
       (unless  (and (integer? n) (exact? n) (>= n 0))
         (error  'build-vector  "~s must be an exact integer >= 0"  n))
       (unless  (procedure? fcn)
         (error  'build-vector  "~s must be a procedure"  fcn))
       (let  ((vec  (make-vector n)))
         (let  loop  ((i  0))
           (if  (= i n)  vec
                (begin
                  (vector-set!  vec  i  (fcn i))
                  (loop  (add1 i)))))))))
  
  (define  build-list
    (polymorphic
     (lambda  (n  fcn)
       (unless  (and (integer? n) (exact? n) (>= n 0))
         (error  'build-list  "~s must be an exact integer >= 0"  n))
       (unless  (procedure? fcn)
         (error  'build-list  "~s must be a procedure"  fcn))
       (if  (zero? n)  '()
            (let  ([head  (list (fcn 0))])
              (let  loop  ([i 1]  [p head])
                (if  (= i n)  head
                     (begin
                       (set-cdr!  p  (list (fcn i)))
                       (loop  (add1 i)  (cdr p))))))))))
  
  (define loop-until
    (polymorphic
     (lambda (start done? next body)
       (let loop ([i start])
         (unless (done? i)
           (body i)
           (loop (next i)))))))
  
  (define boolean=?
    (lambda (x y)
      (unless (and (boolean? x)
                   (boolean? y))
        (raise-type-error 'boolean=? 
                          "boolean"
                          (if (boolean? x) y x)))
      (eq? x y)))
  
  (define (symbol=? x y)
    (unless (and (symbol? x)
		 (symbol? y))
      (raise-type-error 'symbol=? "symbol"
			(if (symbol? x) y x)))
    (eq? x y))

 (define-syntax opt-lambda 
   (lambda (stx)
     (with-syntax ([name (or (syntax-local-infer-name stx)
			     (quote-syntax opt-lambda-proc))])
       (syntax-case stx ()
	 [(_ args body1 body ...)
	  (let ([clauses (let loop ([pre-args null]
				    [args (syntax args)]
				    [needs-default? #f])
			   (syntax-case args ()
			     [id
			      (identifier? (syntax id))
			      (with-syntax ([(pre-arg ...) pre-args])
				(syntax ([(pre-arg ... . id)
					  body1 body ...])))]
                             [()
			      (with-syntax ([(pre-arg ...) pre-args])
				(syntax ([(pre-arg ...)
					  body1 body ...])))]
			     [(id . rest)
			      (identifier? (syntax id))
			      (begin
				(when needs-default?
				  (raise-syntax-error
				   #f
				   "default value missing"
				   stx
				   (syntax id)))
				(loop (append pre-args (list (syntax id)))
				      (syntax rest)
				      #f))]
			     [([id default] . rest)
			      (identifier? (syntax id))
                              (with-syntax ([rest (loop (append pre-args (list (syntax id)))
                                                        (syntax rest)
                                                        #t)]
                                            [(pre-arg ...) pre-args])
                                (syntax ([(pre-arg ...) (name pre-arg ... default)]
                                         . rest)))]
			     [(bad . rest)
			      (raise-syntax-error
			       #f
			       "not an identifier or identifier with default"
			       stx
			       (syntax bad))]
			     [else
			      (raise-syntax-error
			       #f
			       "bad identifier sequence"
			       stx
			       (syntax args))]))])
            (with-syntax ([clauses clauses])
              (syntax/loc stx
                          (letrec ([name
                                    (case-lambda
                                     . clauses)])
                            name))))]))))
 
 (define-syntax local 
   (lambda (stx)
     (syntax-case stx ()
       [(_ (defn ...) body1 body ...)
	(let ([defs (let ([expand-context (generate-expand-context)])
		      (let loop ([defns (syntax->list (syntax (defn ...)))])
			(apply
			 append
			 (map
			  (lambda (defn)
			    (let ([d (local-expand
				      defn
				      expand-context
				      (kernel-form-identifier-list 
				       (quote-syntax here)))]
				  [check-ids (lambda (ids)
					       (for-each
						(lambda (id)
						  (unless (identifier? id)
						    (raise-syntax-error
						     #f
						     "not an identifier for definition"
						     stx
						     id)))
						ids))])
			      (syntax-case d (define-values define-syntaxes begin)
				[(begin defn ...)
				 (loop (syntax->list (syntax (defn ...))))]
				[(define-values (id ...) body)
				 (begin
				   (check-ids (syntax->list (syntax (id ...))))
				   (list d))]
				[(define-values . rest)
				 (raise-syntax-error
				  #f
				  "ill-formed definition"
				  stx
				  d)]
				[(define-syntaxes (id ...) body)
				 (begin
				   (check-ids (syntax->list (syntax (id ...))))
				   (list d))]
				[(define-syntaxes . rest)
				 (raise-syntax-error
				  #f
				  "ill-formed definition"
				  stx
				  d)]
				[_else
				 (raise-syntax-error
				  #f
				  "not a definition"
				  stx
				  defn)])))
			  defns))))])
	  (let ([ids (apply append
			    (map
			     (lambda (d)
			       (syntax-case d ()
				 [(_ ids . __)
				  (syntax->list (syntax ids))]))
			     defs))])
	    (let ([dup (check-duplicate-identifier ids)])
	      (when dup
		(raise-syntax-error
		 #f
		 "duplicate identifier"
		 stx
		 dup)))
	    (with-syntax ([(def ...) defs])
	      (syntax/loc
	       stx
	       (let ()
		 def ...
		 (let ()
		   body1
		   body ...))))))]
       [(_ x body1 body ...)
	(raise-syntax-error
	 #f
	 "not a definition sequence"
	 stx
	 (syntax x))])))

 ;; recur is another name for 'let' in a named let
 (define-syntax recur 
   (lambda (stx)
     (syntax-case stx ()
       [(_ . rest)
	(syntax/loc stx (let . rest))])))

 ;; define a recursive value
 (define-syntax rec
   (lambda (stx)
     (syntax-case stx ()
       [(_ name expr)
	(begin
	  (unless (identifier? (syntax name))
	    (raise-syntax-error
	     #f
	     "not an identifier"
	     stx
	     (syntax name)))
	  (syntax/loc stx
	      (letrec ([name expr])
		name)))])))

 (define-syntax evcase 
   (lambda (stx)
     (syntax-case stx ()
       [(_ val [test body ...] ...)
	(let ([tests (syntax->list (syntax (test ...)))])
	  (with-syntax ([(a-test ...)
			 (map
			  (lambda (t)
			    (syntax-case t (else)
			      [else (syntax #t)]
			      [_else (with-syntax ([t t])
				       (syntax (eqv? evcase-v t)))]))
			  tests)])
	    ;; Make sure else is last:
	    (unless (null? tests)
	      (let loop ([tests tests])
		(unless (null? (cdr tests))
		  (when (and (identifier? (car tests))
			     (module-identifier=? (quote-syntax else) (car tests)))
		    (raise-syntax-error
		     #f
		     "else is not in last clause"
		     stx
		     (car tests)))
		  (loop (cdr tests)))))
	    (syntax/loc stx
	      (let ([evcase-v val])
		(cond
		 [a-test
		  (begin body ...)]
		 ...)))))]
       [(_ val something ...)
	;; Provide a good error message:
	(for-each
	 (lambda (s)
	   (syntax-case s ()
	     [(t a ...)
	      (raise-syntax-error
	       #f
	       "invalid clause"
	       stx
	       s)]))
	 (syntax->list (syntax (something ...))))])))
       
 (define-syntax nor
   (lambda (stx)
     (syntax-case stx ()
       [(_ expr ...)
	(syntax/loc stx (not (or expr ...)))])))
 
 (define-syntax nand
   (lambda (stx)
     (syntax-case stx ()
       [(_ expr ...)
	(syntax/loc stx (not (and expr ...)))])))

 (define-syntax let+
   (lambda (stx)
     (syntax-case stx ()
       [(_ [clause ...] body1 body ...)
	(let ([clauses (syntax->list (syntax (clause ...)))]
	      [bad (lambda (c n)
		     (raise-syntax-error
		      #f
		      (format "illegal use of ~a for a clause" n)
		      stx
		      c))]
	      [var? (lambda (x)
		      (or (identifier? x)
			  (let ([l (syntax->list x)])
			    (and l
				 (pair? l)
				 (eq? (syntax-e (car l)) 'values)
				 (andmap identifier? (cdr l))))))]
	      [normal-var (lambda (x)
			    (if (identifier? x)
				(list x)
				(cdr (syntax-e x))))])
	  ;; syntax checks
	  (for-each
	   (lambda (clause)
	     (syntax-case* clause (val rec vals recs _) (lambda (a b) 
							  (eq? (syntax-e b) 
							       (syntax-e a)))
	       [(val var expr)
		(var? (syntax var))
		'ok]
	       [(rec var expr)
		(var? (syntax var))
		'ok]
	       [(vals (var expr) ...)
		(andmap var? (syntax->list (syntax (var ...))))
		'ok]
	       [(recs (var expr) ...)
		(andmap var? (syntax->list (syntax (var ...))))
		'ok]
	       [(_ expr0 expr ...)
		'ok]
	       [(val . __) (bad clause "val")]
	       [(rec . __) (bad clause "rec")]
	       [(vals . __) (bad clause "vals")]
	       [(recs . __) (bad  clause"recs")]
	       [(_ . __) (bad clause "_")]
	       [_else (raise-syntax-error #f "bad clause" stx clause)]))
	   clauses)
	  ;; result
	(let loop ([clauses clauses])
	  (if (null? clauses)
	      (syntax (let () body1 body ...))
	      (with-syntax ([rest (loop (cdr clauses))])
		(syntax-case* (car clauses) (val rec vals recs _)  (lambda (a b) 
								     (eq? (syntax-e b) 
									  (syntax-e a)))
		  [(val var expr)
		   (with-syntax ([vars (normal-var (syntax var))])
		     (syntax (let-values ([vars expr]) rest)))]
		  [(rec var expr)
		   (with-syntax ([vars (normal-var (syntax var))])
		     (syntax (letrec-values ([vars expr]) rest)))]
		  [(vals (var expr) ...)
		   (with-syntax ([(vars ...) (map normal-var (syntax->list (syntax (var ...))))])
		     (syntax (let-values ([vars expr] ...) rest)))]
		  [(recs (var expr) ...)
		   (with-syntax ([(vars ...) (map normal-var (syntax->list (syntax (var ...))))])
		     (syntax (letrec-values ([vars expr] ...) rest)))]
		  [(_ expr0 expr ...)
		   (syntax (begin expr0 expr ... rest))])))))])))

 (define ns-undefined (gensym))

 (define (namespace-defined? n)
   (unless (symbol? n)
     (raise-type-error 'namespace-defined? "symbol" n))
   (not (eq? (namespace-variable-value n #t (lambda () ns-undefined)) ns-undefined)))

 (define-syntax (this-expression-source-directory stx)
   (syntax-case stx ()
     [(_)
      (let* ([source (syntax-source stx)]
             [source (and (path? source) source)]
             [local (or (current-load-relative-directory) (current-directory))]
	     [dir (plthome-ify
                   (or (and source (file-exists? source)
                            (let-values ([(base file dir?) (split-path source)])
                              (and (path? base)
                                   (path->complete-path base local))))
                       local))])
        (if (and (pair? dir) (eq? 'plthome (car dir)))
          (with-syntax ([d dir])
            #'(un-plthome-ify 'd))
          (with-syntax ([d (if (bytes? dir) dir (path->bytes dir))])
            #'(bytes->path d))))]))

 (define-syntax (this-expression-file-name stx)
   (syntax-case stx ()
     [(_)
      (let* ([f (syntax-source stx)]
             [f (and f (path? f) (file-exists? f)
                     (let-values ([(base file dir?) (split-path f)]) file))])
        (if f
          (with-syntax ([f (path->bytes f)]) #'(bytes->path f))
          #'#f))]))

 ;; This is a macro-generating macro that wants to expand
 ;; expressions used in the generated macro. So it's weird,
 ;; and we put much of the work in a helper macro,
 ;; `finish-syntax-set'.
 (define-syntax (define-syntax-set stx)
   (syntax-case stx ()
     [(_ (id ...) defn ...)
      (let ([ids (syntax->list (syntax (id ...)))])
	;; Check ids ------------------------------
	(for-each (lambda (id)
		    (unless (identifier? id)
		      (raise-syntax-error
		       #f
		       "not an identifier or two identifier in parentheses"
		       stx
		       id)))
		  ids)
	(let ([dup (check-duplicate-identifier ids)])
	  (when dup
	    (raise-syntax-error
	     #f
	     "duplicate identifier"
	     stx
	     dup)))

	;; We'd like to check the `defns', but that requires
	;; and expansion in a different phase. So we move
	;; into that phase using `finish-syntax-set':
	(with-syntax ([orig-stx stx])
	  (syntax/loc stx
	    (define-syntaxes (id ...)
	      (finish-syntax-set orig-stx)))))]))

  (define-syntax (hash-table stx)
    (syntax-case stx (quote)
      [(_ x ...)
       (let loop ([xs #'(x ...)] [flags '()])
         (syntax-case xs (quote)
           [('flag x ...) (loop #'(x ...) (cons #''flag flags))]
           [([key val] ...)
            (with-syntax ([(flag ...) (reverse flags)])
              (syntax/loc stx
                (let ([ht (make-hash-table flag ...)])
                  (hash-table-put! ht key val) ...
                  ht)))]
           [_else (raise-syntax-error 'hash-table "bad syntax" stx)]))]))

  (define-syntax (begin-with-definitions stx)
    ;; Body can have mixed exprs and defns. Wrap expressions with
    ;; `(define-values () ... (values))' as needed, and add a (void)
    ;; at the end if needed.
    (let* ([def-ctx (syntax-local-make-definition-context)]
	   [ctx (list (gensym 'intdef))]
	   [kernel-forms (kernel-form-identifier-list 
			  (quote-syntax here))]
	   [init-exprs (let ([v (syntax->list stx)])
			 (unless v
			   (raise-syntax-error #f "bad syntax" stx))
			 (cdr v))]
	   [exprs (let loop ([exprs init-exprs])
		    (apply 
		     append
		     (map (lambda (expr)
			    (let ([expr (local-expand
					 expr
					 ctx
					 kernel-forms
					 def-ctx)])
			      (syntax-case expr (begin define-syntaxes define-values)
				[(begin . rest)
				 (loop (syntax->list #'rest))]
				[(define-syntaxes (id ...) rhs)
				 (andmap identifier? (syntax->list #'(id ...)))
				 (with-syntax ([rhs (local-transformer-expand
						     #'rhs
						     'expression
						     null)])
				   (syntax-local-bind-syntaxes (syntax->list #'(id ...)) #'rhs def-ctx)
				   (list #'(define-syntaxes (id ...) rhs)))]
				[(define-values (id ...) rhs)
				 (andmap identifier? (syntax->list #'(id ...)))
				 (let ([ids (syntax->list #'(id ...))])
				   (syntax-local-bind-syntaxes ids #f def-ctx)
				   (list expr))]
				[else
				 (list expr)])))
			  exprs)))])
      (let loop ([exprs exprs][prev-stx-defns null][prev-defns null][prev-exprs null])
	(cond
	 [(null? exprs) 
	  #`(letrec-syntaxes+values
	     #,(map stx-cdr (reverse prev-stx-defns))
	     #,(map stx-cdr (reverse prev-defns))
	     #,@(if (null? prev-exprs)
		    (list #'(void))
		    (reverse prev-exprs)))]
	 [(and (stx-pair? (car exprs))
	       (identifier? (stx-car (car exprs)))
	       (module-identifier=? #'define-syntaxes (stx-car (car exprs))))
	  (loop (cdr exprs) (cons (car exprs) prev-stx-defns) prev-defns prev-exprs)]
	 [(and (stx-pair? (car exprs))
	       (identifier? (stx-car (car exprs)))
	       (module-identifier=? #'define-values (stx-car (car exprs))))
	  (loop (cdr exprs)
		prev-stx-defns
		(cons (car exprs)
		      (append
		       (map (lambda (expr)
			      #`(define-values () (begin #,expr (values))))
			    prev-exprs)
		       prev-defns))
		null)]
	 [else
	  (loop (cdr exprs) prev-stx-defns prev-defns (cons (car exprs) prev-exprs))]))))

  (define-syntax (begin-lifted stx)
    (syntax-case stx ()
      [(_ expr0 expr ...)
       (let ([name (syntax-local-name)])
	 (if name
	     (with-syntax ([name name])
	       (syntax-local-lift-expression 
		#'(let ([name (begin expr0 expr ...)])
		    name)))
	     (syntax-local-lift-expression 
	      #'(begin expr0 expr ...))))])))