
;; Provides `define-primitive' and `define-higher-order-primitive'
;; for use in teachpacks for Beginner, especially those that
;; define a primitive operator that consumes a procedure.
;; See doc.txt for more information.

(module prim mzscheme
  (require (lib "error.ss" "lang"))
  
  (provide define-primitive
	   define-higher-order-primitive)

  (define-syntax (define-primitive stx)
    (syntax-case stx ()
      [(_ name implementation)
       (with-syntax ([impl #'(let ([name (lambda argv
                                           (apply implementation argv))])
                               name)])
	 #'(define-syntax (name stx)
	     (syntax-case stx ()
	       [(__ . ___)
		;; HACK: we disable all checks if #%top is 
		;; the usual one, which indicates that we're
		;; not in beginner
		(module-identifier=? #'#%top (datum->syntax-object stx '#%top))
		(syntax/loc stx (impl . ___))]
	       [__
		;; HACK: see above
		(module-identifier=? #'#%top (datum->syntax-object stx '#%top))
		(syntax/loc stx impl)]
	       [(id . args)
                (with-syntax ([tagged-impl (syntax-property
                                            (syntax-property (quote-syntax impl) 'stepper-skip-completely #t)
                                            'stepper-prim-name
                                            (quote-syntax name))])
                  (syntax/loc stx (#%app tagged-impl . args)))]
	       [_else
		(raise-syntax-error
		 #f
		 (string-append
		  "this primitive operator must be applied to arguments; "
		  "expected an open parenthesis before the operator name")
		 stx)])))]))

  (define-syntax (define-higher-order-primitive stx)
    (define (is-proc-arg? arg)
      (not (eq? '_ (syntax-e arg))))
    (syntax-case stx ()
      [(_ name implementation (arg ...))
       (let ([args (syntax->list (syntax (arg ...)))])
         (for-each (lambda (id)
                     (unless (identifier? id)
                       (raise-syntax-error #f "not an identifier" stx id)))
                   (cons (syntax name)
                         args))
	 (let ([new-args (generate-temporaries args)])
	   (with-syntax ([(new-arg ...) new-args]
			 [(checks ...)
			  (map (lambda (arg new-arg)
				 (if (not (is-proc-arg? arg))
				     #'(void)
				     #`(unless (and (identifier? (#,#'syntax #,new-arg))
						    (not (identifier-binding (#,#'syntax #,new-arg))))
					 (raise-syntax-error
					  #f
					  (format
					   "primitive operator ~a expects a defined procedure name (usually `~a') in this position"
					   'name
					   '#,arg)
					  s
					  (#,#'syntax #,new-arg)))))
			       args new-args)]
			 [(wrapped-arg ...)
			  (map (lambda (arg new-arg)
				 (if (not (is-proc-arg? arg)) 
				     new-arg
				     #`(#%top . #,new-arg)))
			       args new-args)]
			 [num-arguments (length args)])
	     (with-syntax ([impl #'(let ([name (lambda (new-arg ...)
						  (implementation new-arg ...))])
				      name)])
	       (syntax/loc stx
		   (define-syntax (name s)
		     (syntax-case s ()
		       [(__ . ___)
			;; HACK: see above
			(module-identifier=? #'#%top (datum->syntax-object s '#%top))
                        (syntax/loc s (impl . ___))]
		       [__
			;; HACK: see above
			(module-identifier=? #'#%top (datum->syntax-object s '#%top))
                        (syntax/loc s impl)]
		       [(__ new-arg ...)
			(begin
			  checks ...
			  ;; s is a well-formed use of the primitive;
			  ;; generate the primitive implementation
                          (with-syntax ([tagged-impl (syntax-property (quote-syntax impl) 'stepper-skip-completely #t)])
                            (syntax/loc s (tagged-impl wrapped-arg ...))))]
		       [(__ . rest)
			(raise-syntax-error
			 #f
			 (format
			  "primitive operator requires ~a arguments"
			  num-arguments)
			 s)]
		       [_else
			(raise-syntax-error
			 #f
			 (string-append
			  "this primitive operator must be applied to arguments; "
			  "expected an open parenthesis before the operator name")
			 s)])))))))])))

