#lang racket

(provide KEYWORDS exn:fail:syntax:pypar?)

(provide (contract-out [syntax->vector (-> syntax? vector?)]
                       [identifier/non-kw? (-> syntax? boolean?)]
                       [raise-pyret-error (-> string? vector? any)]
                       [raise-pyret-error/stx (-> string? syntax? any)]
                       [pypar-syntax-error (-> string? syntax? any)]
                       [app-locations-first (-> any)]
                       [error-no-marks (-> symbol? any)]
                       [internal-error 
                        (->* (string?) () #:rest (listof string?) string?)]
                       [validate-app-locs (-> any/c any)]
                       [validate-srcloc-form (-> vector any)]
                       [app-locs->total-loc (-> any/c any)]
                       [error-bad-arg (-> string? string? positive? any)]
         )
         check-argument-values
         msg-arity
         msg-unexpected
         something-else
         APP-LOCS-MARK-ID
)

(require 2htdp/image)

(define KEYWORDS (list 'struct 'Number 'String 'Image 'List 'Boolean 'define
                       'define-struct 'True 'False 'empty 'def 'and 'or 'not
                       'if 'elif 'else ':done 'struct 'in 'len 'fun
                       'test 'is 'within 'test_error 'matches 'test_range
                       'from 'to
                       'big_bang 'init
                       'to_draw 'draw_width 'draw_height
                       'on_tick 'tick_rate 'tick_limit
                       'on_key 'on_pad 'on_release 'on_mouse 'stop_when 'last_scene))

; internal-error : string string ... -> string
; appends all the given strings, and prepends "pyret internal error: " to them
(define (internal-error first . rest)
  (let ([args (cons first rest)])
    (let ([msg (foldr string-append "" args)])
      (string-append "pyret internal error: " msg))))

;; ----------------------------------------------------------------------------
;; #%app locations
;; ----------------------------------------------------------------------------
(define APP-LOCS-MARK-ID 'pyret-app-locs)
(define (app-locations-first)
  (continuation-mark-set-first (current-continuation-marks) APP-LOCS-MARK-ID))

(define (error-no-marks name)
  (error name
    (internal-error "no app locations in the current continuation marks")))

(define (error-bad-arg function msg num)
  (let ([locs (app-locations-first)])
    (unless locs 
      (error-no-marks 'error-bad-arg))
    (validate-app-locs locs)
    (when (>= num (length locs))
      (error 'error-bad-arg
        (internal-error "argument number is greater than or equal to the size of the arg list")))
    (let ([argloc (list-ref locs num)])
      (raise-pyret-error (format "~a: ~a" function msg) argloc))))

;; validate-app-locs : any -> any
;; makes certain that the argument is of the correct form
(define (validate-app-locs locs)
  (unless (list? locs)
    (error 'validate-marks
      (internal-error "given argument is not a list")))
  (for-each (lambda (v)
              (unless (vector? v)
                (error 'validate-marks
                  (internal-error "one of the list elements is not a vector")))
              (validate-srcloc-form v))
            locs))

(define (app-locs->total-loc locs)
  (validate-app-locs locs)
  (let ([the-op (first locs)]
        [last-arg (last locs)])
    (vector (vector-ref the-op 0)
            (vector-ref the-op 1)
            (vector-ref the-op 2)
            (vector-ref the-op 3)
            (-
              (+ (vector-ref last-arg 3)
                 (vector-ref last-arg 4))
              (vector-ref the-op 3)))))

;; ----------------------------------------------------------------------------

(define (identifier/non-kw? stx)
  (and (identifier? stx)
       (not (ormap (lambda (x) (equal? (syntax-e stx) x)) KEYWORDS))))

;; Pyret exception structure
(define-struct (exn:fail:pyret exn:fail)
  (a-srcloc)
  #:property prop:exn:srclocs
  (lambda (a-struct)
    (match a-struct
      [(struct exn:fail:pyret
         (msg marks a-srcloc))
       (list a-srcloc)])))

;; check to make sure that the given vector can be turned into a srcloc
(define (validate-srcloc-form v)
  (unless (equal? (vector-length v) 5)
    (error 'validate-srcloc-form
      (internal-error 
        (format 
          (string-append "vector does not have the correct length: "
                          "it should be 5, but it is ~a")
          (vector-length v)))))
  (let ([v1 (vector-ref v 1)]
        [v2 (vector-ref v 2)]
        [v3 (vector-ref v 3)]
        [v4 (vector-ref v 4)])
    (unless (or (exact-positive-integer? v1) (false? v1))
      (error 'validate-srcloc-form
        (internal-error
          (format
            (string-append "element 1 of a srcloc should either be #f, "
                           "or an exact positive integer; given: ~a")
            v1))))
    (unless (or (exact-nonnegative-integer? v2) (false? v2))
      (error 'validate-srcloc-form
        (internal-error
          (format
            (string-append "element 2 of a srcloc should either be #f, "
                           "or an exact nonnegative integer; given ~a")
            v2))))
    (unless (or (exact-positive-integer? v3) (false? v3))
      (error 'validate-srcloc-form
        (internal-error
          (format
            (string-append "element 3 of a srcloc should either be #f, "
                           "or an exact positive integer; given ~a")
            v3))))
    (unless (or (exact-nonnegative-integer? v4) (false? v4))
      (error 'validate-srcloc-form
        (internal-error
          (format
            (string-append "element 4 of a srcloc should either be #f, "
                           "or an exact nonnegative integer; given ~a")
            v4))))
    (void)))

;; Given a vector, turn it into a srcloc
(define (vector->srcloc v)
  (validate-srcloc-form v)
  (srcloc (vector-ref v 0)
          (vector-ref v 1)
          (vector-ref v 2)
          (vector-ref v 3)
          (vector-ref v 4)))

;; Given a srcloc, make it into a vector
(define (srcloc->vector s)
  (vector (srcloc-source s)
          (srcloc-line s)
          (srcloc-column s)
          (srcloc-position s)
          (srcloc-span s)))

;; Given a syntax-object, return the srcloc, in vector form
(define (syntax->vector stx)
  (vector (syntax-source stx)
          (syntax-line stx)
          (syntax-column stx)
          (syntax-position stx)
          (syntax-span stx)))

;; Given a syntax object, return the srcloc structure
(define (syntax->srcloc stx)
  (srcloc (syntax-source stx)
          (syntax-line stx)
          (syntax-column stx)
          (syntax-position stx)
          (syntax-span stx)))

(define (raise-pyret-error msg srcloc)
  (raise (make-exn:fail:pyret msg
                              (current-continuation-marks)
                              (vector->srcloc srcloc))))

(define (raise-pyret-error/stx msg stx)
  (raise (make-exn:fail:pyret msg
                              (current-continuation-marks)
                              (syntax->srcloc stx))))

(define-struct (exn:fail:syntax:pypar exn:fail)
  (a-srcloc)
  #:property prop:exn:srclocs
  (lambda (a-struct)
    (match a-struct
      [(struct exn:fail:syntax:pypar
         (msg marks a-srcloc))
       (list a-srcloc)])))

(define (pypar-syntax-error msg stx)
  (raise (make-exn:fail:syntax:pypar msg
                                     (current-continuation-marks)
                                     (syntax->srcloc stx))))

(define (check-argument-values name argl)
  (for-each
    (λ (v)
     (match v
       [(vector val contract str loc)
        (if (not (contract val))
            (raise-pyret-error (msg-unexpected name str val) loc)
            (void))]))
   argl))

(define (msg-arity name modifier wanted got)
  (format
    (string-append
      "~a: expected ~a ~a ~a; got ~a")
    (symbol->string name)
    modifier
    wanted
    (if (equal? wanted 1) "argument" "arguments")
    got))

(define (msg-unexpected name wanted got)
  (let ([name-str (if (symbol? name) (string-append (symbol->string name) ": ") "")])
    (string-append name-str
                   "expected an argument of type <"
                   wanted
                   ">, but given "
                   (something-else got))))
                   

(define (something-else v)
  (cond
    [(number? v) "a number"]
    [(string? v) "a string"]
    [(image? v) "an image"]
    [(list? v) "a list"]
    [(boolean? v)
     (if v
         "True"
         "False")]
    [else "something else"]))