;; 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.rkt")
                      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)])
	 #'(begin
             ;; Make sure that `implementation' is bound:
             (define-values () (begin (lambda () implementation) (values)))
             ;; Bind `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
                        "expected a function call, but there is no open parenthesis before this function"
                        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 "expected a variable" 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
					   "expects a function in this position")
					  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)
                             (let ([num-actuals (length (syntax->list #'rest))])
                               (raise-syntax-error
                                #f
                                (format
                                 "this function expects ~a argument~a, here it is provided ~a argument~a"
                                 num-arguments
                                 (if (= num-arguments 1) "" "s")
                                 num-actuals
                                 (if (= num-actuals 1) "" "s"))
                                s))]
                            [_
                             (raise-syntax-error
                              #f
                              "expected a function call, but there is no open parenthesis before this function"
                              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)))])))