#lang racket

;; file: check.rkt
;; author: Bill Turtle
;;
;; Takes the stage 1 parse, runs a "return check" over the AST
;; (always use "return" in 'def', and never use 'return' in 'fun'),
;; and finally, once we know we have a valid parse, run an indentation
;; check. If this succeeds (correct indentation) then we give the completed
;; parse to Racket (more specifically, we give it to our custom BSL language
;; (htdp/bsl with begin and local)).

(require "form-1.rkt"
         "parse.rkt"
         syntax/stx)

(require (rename-in racket (datum->syntax d->s)))

(provide to-racket check-indent check-return)

;; check-call : ((and/c syntax? (symbol? (syntax-e))) -> syntax?)
;; maps identifiers such as "number_to_string" to the Racket
;; number->string
(define (check-call stx)
  (let ([id (syntax->datum stx)])
    (if (not (symbol? id))
        (error 'check-call (string-append
                             "check-call was not called on an identifier.  "
                             (format
                               "offender located at line ~a, column ~a\n"
                               (syntax-line stx)
                               (syntax-column stx))))
        (case id
          ;; numbers, integers, etc
          [(current_seconds) 'current-seconds]
          [(exact_to_inexact) 'exact->inexact]
          [(imag_part) 'imag-part] ; no support for imaginary numbers (yet...)
          [(inexact_to_exact) 'inexact_to_exact]
          [(integer_to_char) 'integer->char]
          [(integer_sqrt) 'integer-sqrt]
          [(make_polar) 'make-polar]
          [(make_rectangular) 'make-rectangular]
          [(number_to_string) 'number->string]
          [(real_part) 'real-part]
          ;; booleans
          [(boolean_eq?) 'boolean=?]
          ;; symbols
          [(symbol_to_string) 'symbol->string]
          [(symbol_eq?) 'symbol=?]
          ;; lists
          [(list_star) 'list*]
          [(list_ref) 'list-ref]
          [(make_list) 'make-list]
          ;; posns
          [(make_posn) 'make-posn]
          ;[(posn.x) 'posn-x]
          ;[(posn.y) 'posn-y]
          ;; characters
          [(char_to_integer) 'char->integer]
          [(char_alphabetic?) 'char-alphabetic?]
          [(char_ci_leq?) 'char-ci<=?]
          [(char_ci_lt?) 'char-ci<?]
          [(char_ci_eq?) 'char-ci=?]
          [(char_ci_geq?) 'char-ci>=?]
          [(char_ci_gt?) 'char-ci>?]
          [(char_downcase) 'char-downcase]
          [(char_lower_case?) 'char-lower-case?]
          [(char_numeric?) 'char-numeric?]
          [(char_upcase) 'char-upcase]
          [(char_upper_case?) 'char-upper-case?]
          [(char_whitespace?) 'char-whitespace?]
          [(char_leq?) 'char<=?]
          [(char_lt?) 'char<?]
          [(char_eq?) 'char=?]
          [(char_geq?) 'char>=?]
          [(char_gt?) 'char>?]
          ;;strings
          [(int_to_string) 'int->string]
          [(list_to_string) 'list->string]
          [(make_string) 'make->string]
          [(string_to_int) 'string->int]
          [(string_to_list) 'string->list]
          [(string_to_number) 'string->number]
          [(string_alphabetic?) 'string-alphabetic?]
          [(string_append) 'string-append]
          [(string_ci_leq?) 'string-ci<=?]
          [(string_ci_lt?) 'string-ci<?]
          [(string_ci_eq?) 'string-ci=?]
          [(string_ci_geq?) 'string-ci>=?]
          [(string_ci_gt?) 'string-ci>?]
          [(string_copy) 'string-copy]
          [(string_ith) 'string-ith]
          [(string_length) 'string-length]
          [(string_lower_case?) 'string-lower-case?]
          [(string_numeric?) 'string-numeric?]
          [(string_ref) 'string-ref]
          [(string_upper_case?) 'string-upper-case?]
          [(string_whitespace?) 'string-whitespace?]
          [(string_leq?) 'string<=?]
          [(string_lt?) 'string<?]
          [(string_eq?) 'string=?]
          [(string_geq?) 'string>=?]
          [(string_gt?) 'string>?]
          ;; images
          [(image_eq?) 'image=?]
          ;; misc
          [(eof_object?) 'eof-object?]
          [(approx_eq?) 'equal~]
          ;; if it made it this far, it's good
          [else id]))))

;; get-syntax : ((or/c syntax? stage-1-parse) -> syntax?)
;;
;; If given syntax, evaluates to that. Otherwise, it returns the first syntax
;; object of the stage-1-parse
(define (get-syntax something)
  (if (syntax? something)
      something
      (type-case stage-1-parse something
        [stx-num (val) val]
        [stx-str (val) val]
        [stx-char (val) val]
        [stx-id (val) val]
        [stx-return (kwd expr) kwd]
        [stx-binding (id eq expr) (get-syntax id)]
        [stx-struct (kwd id args) kwd]
        [stx-fun (kwd id args colon body) kwd]
        [stx-def (kwd id args colon body) kwd]
        [stx-let (let-kwd bindings in-kwd colon body) let-kwd]
        [stx-where (body kwd bindings) (get-syntax body)]
        [stx-app (id args) (get-syntax id)]
        [stx-lst (lst) (get-syntax (car lst))]
        [stx-bool (val) val]
        [stx-neg (kwd expr) kwd]
        [stx-binop (op left right) (get-syntax left)]
        [stx-not (kwd expr) kwd]
        [stx-if (kwd test-expr colon then-expr) kwd]
        [stx-else (kwd colon then-expr) kwd]
        [stx-if-else (if-clause else-clause) (get-syntax if-clause)]
        [stx-elif (kwd test-expr colon then-expr) kwd]
        [stx-cond (if-clause elif-lst else-clause)
          (get-syntax if-clause)]
        [else (error 'get-syntax
                     "this case should never be evaluated")])))

;; check-indent-level : (number
;;                       (or/c syntax? stage-1-parse?)
;;                       (or/c syntax? stage-1-parse?)
;;                       -> #t)
(define (check-indent-level il thing1 thing2)
  (let ([stx1 (get-syntax thing1)]
        [stx2 (get-syntax thing2)])
    #|
    (printf "~a ~a ~a ~a\n"
            (syntax-line stx1)
            (syntax-line stx2)
            (syntax-column stx1)
            (syntax-column stx2))
    |#
    (if (or (= (syntax-line stx1) (syntax-line stx2)) ; same line
            (>= (- (syntax-column stx2) (syntax-column stx1)) il)) ; properly indented
        #t
        (raise-syntax-error #f
                            "this expression is not properly indented"
                            stx2))))

;; check-indent: (stage-1-parse -> stage-1-parse)
;;
;; Runs an indentation check over the stage 1 parse, and raises an exception
;; if the code is not properly indented. If all is well, it evaluates to the
;; original stage 1 parse.
(define (check-indent parse)
  (let ([il 2]) ;; number of spaces we want for indentation
    (type-case stage-1-parse parse
      [stx-begin (lst)
        (begin
          (map check-indent lst)
          parse)]
      [stx-fun (kwd id args colon body)
        (begin (check-indent-level il kwd body)
               (check-indent body)
               parse)]
      [stx-def (kwd id args colon body)
        (begin (check-indent-level il kwd body)
               (check-indent body)
               parse)]
      [stx-let (let-kwd bindings in-kwd colon body)
        (begin (check-indent-level 0 let-kwd in-kwd)
               ; ^^^ 'in' should at least be same column as 'let'
               (check-indent-level il let-kwd body)
               (check-indent body)
               parse)]
      [stx-where (body kwd bindings)
        (begin (check-indent-level 0 body kwd)
               (check-indent body)
               parse)]
      [stx-if (kwd test-expr colon then-expr)
        (begin (check-indent-level il kwd then-expr)
               (check-indent test-expr)
               (check-indent then-expr)
               parse)]
      [stx-else (kwd colon then-expr)
        (begin (check-indent-level il kwd then-expr)
               (check-indent then-expr)
               parse)]
      [stx-if-else (if-clause else-clause)
        (begin (check-indent-level 0 if-clause else-clause)
               ; ^^^ if and else should be in same column
               (check-indent if-clause)
               (check-indent else-clause)
               parse)]
      [stx-elif (kwd test-expr colon then-expr)
        (begin (check-indent-level il kwd then-expr)
               (check-indent test-expr)
               (check-indent then-expr)
               parse)]
      [stx-cond (if-clause elif-lst else-clause)
        (begin (check-indent if-clause)
               (map check-indent elif-lst)
               (check-indent else-clause)
               parse)]
      [else parse]))) ; indentation not important

;; check-return: (stage-1-parse -> stage-1-parse)
;; checks for correct usage of return
(define (check-return parse)
  ;; check-return-helper: (stage-1-parse bool -> stage-1-parse)
  (define (check-return-helper parse in-a-def?)
    (type-case stage-1-parse parse
      [stx-eof () #t]
      [stx-begin (defs/exprs)
        (andmap (curryr check-return-helper in-a-def?) defs/exprs)]
      [stx-num (val)
        (if in-a-def?
            (raise-syntax-error #f
                                "no return inside of def"
                                val)
            #t)]
      [stx-str (val)
        (if in-a-def?
            (raise-syntax-error #f
                                "no return inside of def"
                                val)
            #t)]
      [stx-char (val)
        (if in-a-def?
            (raise-syntax-error #f
                                "no return inside of def"
                                val)
            #t)]
      [stx-id (val)
        (if in-a-def?
            (raise-syntax-error #f
                                "no return inside of def"
                                val)
            #t)]
      [stx-return (kwd val)
        (if (not in-a-def?)
            (raise-syntax-error #f
                                "return not allowed outside of a def"
                                kwd)
            #t)]
      [stx-binding (id eq expr)
        (check-return-helper expr #f)]
      [stx-struct (kwd id args)
        (andmap (curryr check-return-helper #f) args)]
      [stx-fun (kwd id args colon body)
        (and (andmap (curryr check-return-helper #f) args)
             (check-return-helper body #f))]
      [stx-def (kwd id args colon body)
        (and (andmap (curryr check-return-helper #f) args)
             (check-return-helper body #t))]
      [stx-let (let-kwd bindings in-kwd colon body)
        (and (andmap (curryr check-return-helper #f) bindings)
             (check-return-helper body #f))] ; let is never in a def
      [stx-where (body kwd bindings)
        (and (check-return-helper body #f)
             (andmap (curryr check-return-helper #f) bindings))] ; same
      [stx-app (id args)
        (andmap (curryr check-return-helper #f) args)]
      [stx-lst (lst)
        (andmap (curryr check-return-helper #f) lst)]
      [stx-bool (val)
        (if in-a-def?
            (raise-syntax-error #f
                                "no return inside of a def"
                                val)
            #f)]
      [stx-neg (kwd expr)
        (check-return-helper expr #f)]
      [stx-binop (op left right)
        (and (check-return-helper left #f)
             (check-return-helper right #f))]
      [stx-not (kwd expr)
        (check-return-helper expr in-a-def?)]
      [stx-if (kwd test colon body)
        (and (check-return-helper test #f)
             (check-return-helper body in-a-def?))]
      [stx-else (kwd colon body)
        (check-return-helper body in-a-def?)]
      [stx-if-else (if-clause else-clause)
        (and (check-return-helper if-clause in-a-def?)
             (check-return-helper else-clause in-a-def?))]
      [stx-elif (kwd test colon body)
        (and (check-return-helper test #f)
             (check-return-helper body in-a-def?))]
      [stx-cond (if-clause elif-lst else-clause)
        (and (check-return-helper if-clause in-a-def?)
             (andmap (curryr check-return-helper in-a-def?) elif-lst)
             (check-return-helper else-clause in-a-def?))]))
  (if (check-return-helper parse #f)
      parse
      (error 'check-return "this case should never happen")))


;; to-racket : (stage-1-parse -> syntax)
;; converts from our intermediate form to legitimate Racket syntax
(define (to-racket ast)
  (type-case stage-1-parse ast
    [stx-eof () eof]
    [stx-begin (defs/exprs) (cons (d->s #f 'begin) (map to-racket defs/exprs))]
    [stx-num (val) val]
    [stx-str (val) val]
    [stx-char (val) val]
    [stx-id (val) val]
    [stx-return (kwd val)
      (let ((ret (to-racket val)))
        (list kwd ret))]
    [stx-binding (id eq expr)
      (let ((id-stx (to-racket id))
            (expr-stx (to-racket expr)))
        (list (d->s #f 'define) id-stx expr-stx))]
    [stx-struct (kwd id args)
      (let ((id-stx (to-racket id))
            (args-stx (map to-racket args)))
        (list (syntax/loc kwd pyret-struct)
              id-stx
              args-stx))]
    [stx-fun (kwd id args colon body)
      (let ((id-stx (to-racket id))
            (args-stx (map to-racket args))
            (body-stx (to-racket body)))
        (list (d->s #f 'fun) id-stx args-stx body-stx))]
    [stx-def (kwd id args colon body)
      (let ((id-stx (to-racket id))
            (args-stx (map to-racket args))
            (body-stx (to-racket body)))
        (list (d->s #f 'def) id-stx args-stx body-stx))]
    [stx-let (let-kwd bindings in-kwd colon body)
      (let ((bindings-stx (map to-racket bindings))
            (body-stx (to-racket body)))
        (list (d->s #f 'local)
              bindings-stx
              body-stx))]
    [stx-where (body kwd bindings)
      (let ((body-stx (to-racket body))
            (bindings-stx (map to-racket bindings)))
        (list (d->s #f 'local)
              bindings-stx
              body-stx))]
    [stx-app (id args)
      (cons (to-racket id) (map to-racket args))]
    [stx-lst (lst) (cons #'list (map to-racket lst))]
    [stx-bool (val) val]
    [stx-neg (kwd expr)
      (let ((expr-stx (to-racket expr)))
        (list kwd expr-stx))]
    [stx-binop (op left right) 
      (let ((left-stx (to-racket left))
            (right-stx (to-racket right)))
        (list op left-stx right-stx))]
    [stx-not (kwd expr)
      (let ((expr-stx (to-racket expr)))
        (list kwd expr-stx))]
    [stx-if (kwd test-expr colon then-expr)
      (let ((test-expr-stx (to-racket test-expr))
            (then-expr-stx (to-racket then-expr)))
        (list test-expr-stx then-expr-stx))]
    [stx-else (kwd colon then-expr)
      (to-racket then-expr)]
    [stx-if-else (if-clause else-clause)
      (let ((if-clause-stx (to-racket if-clause))
            (else-clause-stx (to-racket else-clause)))
        (append
         (cons (stx-if-kwd if-clause) if-clause-stx)
         (list else-clause-stx)))]
    [stx-elif (kwd test-expr colon then-expr)
      (let ((test-expr-stx (to-racket test-expr))
              (then-expr-stx (to-racket then-expr)))
        (list test-expr-stx then-expr-stx))]
    [stx-cond (if-clause elif-lst else-clause)
      (let ((if-clause-stx (to-racket if-clause))
            (elif-lst-stx (map to-racket elif-lst))
            (else-clause-stx (to-racket else-clause)))
        ; (cond (if-test if-expr) (elif-test elif-expr)... (else-test else-expr))
        (cons
         (d->s #f 'cond)
         (append ; ((if-test if-expr) (elif-test elif-expr)... (else-test else-expr))
          (cons ; ((if-test if-expr) (elif-test elif-expr)...)
           if-clause-stx ; (if-test if-expr)
           elif-lst-stx) ; ((elif-test elif-expr)...)
          (list (cons (d->s #f 'else) (list else-clause-stx))))))] ; ((else else-expr))
    #;(else (error 'to-racket "this functionality not yet implemented"))))