
;; 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 manual for more information.

(module prim mzscheme
  (require lang/error
	   (rename lang/htdp-beginner beginner-app #%app))
  
  (require-for-syntax (prefix fo: "private/firstorder.ss")
                      stepper/private/shared)
  
  (provide define-primitive
	   define-higher-order-primitive
	   provide-primitive
	   provide-higher-order-primitive
	   provide-primitives
           first-order->higher-order)

  (define-syntax (define-primitive stx)
    (syntax-case stx ()
      [(_ name implementation)
       (with-syntax ([impl #'(let ([name (lambda argv
                                           (apply implementation argv))])
                               name)])
	 #'(define-syntax name 
             (fo:make-first-order
              (lambda (stx)
                (with-syntax ([tagged-impl (stepper-syntax-property
                                            (stepper-syntax-property (quote-syntax impl) 'stepper-skip-completely #t)
                                            'stepper-prim-name
                                            (quote-syntax name))])
                  (syntax-case stx ()
                    [(_ . body)
                     ;; HACK: we disable all checks if #%app is not beginner-app
                     (not (module-identifier=? #'beginner-app (datum->syntax-object stx '#%app)))
                     (syntax/loc stx (tagged-impl . body))]
                    [_
                     ;; HACK: see above
                     (not (module-identifier=? #'beginner-app (datum->syntax-object stx '#%app)))
                     (syntax/loc stx tagged-impl)]
                    [(id . args)
                     (syntax/loc stx (#%plain-app tagged-impl . args))]
                    [_
                     (raise-syntax-error
                      #f
                      (string-append
                       "this primitive operator must be applied to arguments; "
                       "expected an open parenthesis before the operator name")
                      stx)])))
              ((syntax-local-certifier #t)
               #'impl))))]))

  (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 (identifier? (#,#'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)
				 (cond
				  [(not (is-proc-arg? arg)) new-arg]
				  [else #`(first-order->higher-order #,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
                     (fo:make-first-order
                      (lambda (s)
                        (with-syntax ([tagged-impl (stepper-syntax-property
                                                    (stepper-syntax-property (quote-syntax impl) 'stepper-skip-completely #t)
                                                    'stepper-prim-name
                                                    (quote-syntax name))])
                          (syntax-case s ()
                            [(_ . body)
                             ;; HACK: see above
                             (not (module-identifier=? #'beginner-app (datum->syntax-object s '#%app)))
                             (syntax/loc s (tagged-impl . body))]
                            [_
                             ;; HACK: see above
                             (not (module-identifier=? #'beginner-app (datum->syntax-object s '#%app)))
                             (syntax/loc s tagged-impl)]
                            [(_ new-arg ...)
                             (begin
                               checks ...
                               ;; s is a well-formed use of the primitive;
                               ;; generate the primitive implementation
                               (syntax/loc s (tagged-impl wrapped-arg ...))
                               )]
                            [(_ . rest)
                             (raise-syntax-error
                              #f
                              (format
                               "primitive operator requires ~a arguments"
                               num-arguments)
                              s)]
                            [_
                             (raise-syntax-error
                              #f
                              (string-append
                               "this primitive operator must be applied to arguments; "
                               "expected an open parenthesis before the operator name")
                              s)])))
                      ((syntax-local-certifier #t)
                       #'impl))))))))]))

  (define-syntax (first-order->higher-order stx)
    (syntax-case stx ()
      [(_ id) (identifier? #'id) (fo:first-order->higher-order #'id)]
      [(_ expr) #'expr]))

  (define-syntax (provide-primitive stx)
    (syntax-case stx ()
      [(_ name)
       (with-syntax ([ex-name ((make-syntax-introducer) #'name)])
	 #'(begin
	     (define-primitive ex-name name)
	     (provide ex-name)))]))

  (define-syntax (provide-primitives stx)
    (syntax-case stx ()
      [(_ name ...)
       #'(begin
	   (provide-primitive name)
	   ...)]))

  (define-syntax (provide-higher-order-primitive stx)
    (syntax-case stx ()
      [(_ name (arg ...))
       (with-syntax ([ex-name ((make-syntax-introducer) #'name)])
	 #'(begin
	     (define-higher-order-primitive ex-name name (arg ...))
	     (provide ex-name)))])))


