#lang racket
(require "form-1.rkt"
"parse.rkt"
syntax/stx)
(require (rename-in racket (datum->syntax d->s)))
(provide to-racket check-indent check-return)
(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
[(current_seconds) 'current-seconds]
[(exact_to_inexact) 'exact->inexact]
[(imag_part) 'imag-part] [(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]
[(boolean_eq?) 'boolean=?]
[(symbol_to_string) 'symbol->string]
[(symbol_eq?) 'symbol=?]
[(list_star) 'list*]
[(list_ref) 'list-ref]
[(make_list) 'make-list]
[(make_posn) 'make-posn]
[(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>?]
[(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>?]
[(image_eq?) 'image=?]
[(eof_object?) 'eof-object?]
[(approx_eq?) 'equal~]
[else id]))))
(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")])))
(define (check-indent-level il thing1 thing2)
(let ([stx1 (get-syntax thing1)]
[stx2 (get-syntax thing2)])
(if (or (= (syntax-line stx1) (syntax-line stx2)) (>= (- (syntax-column stx2) (syntax-column stx1)) il)) #t
(raise-syntax-error #f
"this expression is not properly indented"
stx2))))
(define (check-indent parse)
(let ([il 2]) (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)
(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)
(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])))
(define (check-return 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))] [stx-where (body kwd bindings)
(and (check-return-helper body #f)
(andmap (curryr check-return-helper #f) bindings))] [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")))
(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)))
(cons
(d->s #f 'cond)
(append (cons if-clause-stx elif-lst-stx) (list (cons (d->s #f 'else) (list else-clause-stx))))))] (else (error 'to-racket "this functionality not yet implemented"))))