#lang racket

#|

File: semantics/first-order.rkt
Author: Bill Turtle

|#

(require (for-syntax "../utilities.rkt"))
(require (prefix-in pyret: "hash-percents.rkt"))
(require racket/stxparam)
(provide make-first-order define-first-order make-first-order-and-provide be-first-order)

(define-syntax-parameter be-first-order #t)

(define-syntax (make-first-order stx)
  (syntax-case stx ()
    [(_ new-id proc)
     (syntax/loc stx
       (define-syntax (new-id stx)
         (syntax-case stx ()
           [id
            (identifier? #'id)
            (if (syntax-parameter-value (syntax be-first-order))
                (raise-syntax-error #f
                                    "expected a function call, but there are no arguments"
                                    stx)
                (syntax/loc stx proc))]
           [(id args (... ...))
            (quasisyntax/loc stx
              (pyret:#%app #,(syntax/loc (syntax id) proc) args (... ...)))])))]))

(define-syntax (define-first-order stx)
  (syntax-case stx ()
    [(_ id l)
     (identifier? #'id)
     (syntax/loc stx
       (begin
         (define internal-name l)
         (make-first-order id internal-name)))]))

(define-syntax (make-first-order-and-provide stx)
  (syntax-case stx ()
    [(_ [name-to-use orig name-to-provide] ...)
     (syntax/loc stx
       (begin
         (make-first-order-and-provide name-to-use orig name-to-provide) ...))]
    [(_ name-to-use orig name-to-provide)
     (syntax/loc stx
       (begin
        (make-first-order name-to-use orig)
        (provide (rename-out [name-to-use name-to-provide]))))]))