#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 check-and-compile)

;; 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"))))

(define (check-and-compile parse)
  (to-racket (check-indent (check-return parse))))