#lang racket

#|
File: semantics/define.rkt
Author: Bill Turtle (wrturtle)

Provides the various `define` macros.
|#

(require (for-syntax syntax/parse))
(require (for-syntax racket/list))
(require (for-syntax racket/bool))
(require "../utilities.rkt")
(require (for-syntax "../utilities.rkt"))
(require "first-order.rkt")
(require racket/stxparam)

;;---------------------------------------------------------------------------;;
;;                                  Return                                   ;;
;;---------------------------------------------------------------------------;;

(define-for-syntax (return->error stx)
  (raise-syntax-error #f
    "return cannot be used outside the context of a `def` form"
    stx))

(define-syntax-parameter return return->error)
(provide return)

;;---------------------------------------------------------------------------;;
;;                          Lower-level define syntax                        ;;
;;                        (`fun` and `def` reduce to this)                   ;;
;;---------------------------------------------------------------------------;;

(define-syntax (make-a-define stx)
  (syntax-parse stx
    [(_ mac-name:id no-args-allowed:boolean define-to-use:expr)
     (syntax/loc stx
       (define-syntax (mac-name stx)
         ; This is straight from the teaching languages.
         (define (identifier-is-bound? id)
           (or (identifier-binding id)
               ;; identifier-binding returns #f for variable bound at the top-level,
               ;; check explicitly:
               (and (namespace-variable-value (syntax-e id) #t (lambda () #f)) #t)))
         (define (check-top-level-not-defined id)
           (when (identifier-is-bound? id)
             (raise-syntax-error #f
                                 (string-append "this name was defined previously, "
                                                "and cannot be re-defined")
                                 id)))
         (syntax-parse stx
           [(_ var-name:id body:expr)
            ;; easy -- a variable definition
            (if (not (identifier/non-kw? (syntax var-name)))
                (raise-pyret-error/stx
                  "keyword names cannot be re-defined"
                  (syntax var-name))
                (begin
                  (check-top-level-not-defined (syntax var-name))
                  (syntax/loc stx
                    (define var-name body))))]
           [(_ (fun-name:id args:id (... ...)) body:expr ...+)
            ;; this would be a function definition
            (begin
              (unless (identifier/non-kw? (syntax fun-name))
                (raise-pyret-error/stx
                  "keywords cannot be used as function names"
                  (syntax fun-name)))
              (check-top-level-not-defined (syntax fun-name))
              (let ([args-list (syntax->list (syntax (args (... ...))))])
                (when (not no-args-allowed)
                  (when (empty? args-list)
                    (raise-pyret-error/stx
                      (string-append
                        "functions must have at least one argument")
                      (second (syntax->list stx)))))
                ;; check to make sure that the name of the function is
                ;; not used as the name of an argument
                (for-each
                  (lambda (s)
                    (when (symbol=? (syntax-e (syntax fun-name)) (syntax-e s))
                      (raise-pyret-error/stx
                        (string-append
                          "the name of the function must not be used as the "
                          "name of an argument")
                        s)))
                  args-list)
                ;; check to make sure that argument names are not duplicated
                (let loop ([seen empty]
                           [togo args-list])
                  (cond
                    [(empty? togo) (void)]
                    [else
                     (let ([f (first togo)]
                           [r (rest togo)])
                       (let ([id (syntax-e f)])
                         (when (findf (lambda (c) (symbol=? c id)) seen)
                           (raise-pyret-error/stx
                             (string-append
                               "found an argument name that has been used more "
                               "than once")
                             f))
                         (loop (cons id seen) r)))]))
                ;; well, it looks like we can actually define it
                (with-syntax ([num-expected-args (length args-list)])
                  (syntax/loc stx
                    (define-to-use fun-name
                      (lambda args-given
                        (let ([the-fun
                               (lambda (args (... ...)) body (... ...))])
                          (let ([num-args-given (length args-given)])
                            (if (equal? num-args-given num-expected-args)
                                (apply the-fun args-given)
                                (let ([the-locs (app-locations-first)])
                                  (unless the-locs
                                    (error-no-marks 'semantics/define))
                                  (let ([srcvec (app-locs->total-loc the-locs)])
                                    (raise-pyret-error
                                      (format
                                        (string-append
                                          "function ~a expects ~a argument(s) "
                                          "but was given ~a")
                                        (quote fun-name)
                                        num-expected-args
                                        num-args-given)
                                      srcvec))))))))))))])))]))

(make-a-define beginner-semantic-define #f define-first-order)
(make-a-define intermediate-semantic-define #f define)
(make-a-define advanced-semantic-define #t define)

;;---------------------------------------------------------------------------;;
;;                             `fun` and `def`                               ;;
;;---------------------------------------------------------------------------;;

;; macro to generate pairs of `fun` and `def`
(define-syntax (make-fun-and-def stx)
  (syntax-parse stx
    [(_ fun-name:id def-name:id mult-exprs-allowed:boolean semantics:id)
     (syntax/loc stx
       (begin
         (begin-for-syntax
           (define-syntax-class define-form
             #:literals (fun-name def-name)
             (pattern (def-name name:id value:expr))
             (pattern (fun-name (name:id args:id (... ...))
                                locals:define-form (... ...)
                                body:expr ...+))))
         (define-syntax (fun-name stx)
           (syntax-parse stx
             [(_ (name:id args:id (... ...))
                 locals:define-form (... ...)
                 body:expr ...+)
              (let ([body-list (syntax->list (syntax (body (... ...))))])
                (when (and (not mult-exprs-allowed) (> (length body-list) 1))
                  (raise-pyret-error
                   (format
                    (string-append "there must only be one expression "
                                   "in the body of a function; found ~a")
                    (length body-list))
                   (app-locs->total-loc (map syntax->vector body-list))))
                (syntax/loc stx
                  (semantics (name args (... ...))
                    (syntax-parameterize ([return return->error])
                      locals (... ...)
                      body (... ...)))))]))
         (define-syntax (def-name stx)
           (syntax-parse stx
             [(_ name:id value:expr)
              (syntax/loc stx
                (semantics name value))]))))]))

(make-fun-and-def beginner-fun beginner-def #f beginner-semantic-define)
(make-fun-and-def intermediate-fun intermediate-def #f intermediate-semantic-define)
(provide beginner-def intermediate-def)
(provide beginner-fun intermediate-fun)