;;;; Cyclone Scheme
;;;; https://github.com/justinethier/cyclone
;;;;
;;;; Copyright (c) 2014-2016, Justin Ethier
;;;; All rights reserved.
;;;;
;;;; This module contains the s-expression parser and supporting functions.
;;;;
(define-library (scheme read)
  (import (scheme base)
          (scheme cyclone common)
          (scheme cyclone util)
          ;(scheme write)
          (scheme char))
  (export
    read
    read-all
    read-all/source
    include
    include-ci)
  (inline
    Cyc-opaque-eq?
    Cyc-opaque-unsafe-eq?
    Cyc-opaque-unsafe-string?
    Cyc-opaque-unsafe-string->number)
  (begin

(define *sym-dot* (string->symbol "."))
(define *sym-unquote-splicing* (string->symbol ",@"))
(define *sym-datum-comment* (string->symbol "#;"))

(define-syntax include
  (er-macro-transformer
   (lambda (expr rename compare)

     (define (dirname filename)
       (let loop ((index (string-length filename)))
         (if (zero? index)
             ""
             (let ((index (- index 1)))
               (if (char=? (string-ref filename index) #\/)
                   (substring filename 0 index)
                   (loop index))))))

     (define (massage filename)
       (cond
        ;; may happen in the REPL
        ((not (current-expand-filepath)) filename)
        ;; absolute filename
        ((char=? (string-ref filename 0) #\/) filename)
        ;; otherwise, open the file relative to the library that is
        ;; expanded
        (else (let ((target (string-append (dirname (current-expand-filepath)) "/" filename)))
                ;; if the target exists use, otherwise fallback to the
                ;; backward compatible behavior.
                (if (file-exists? target)
                    target
                    filename)))))

     `(begin
        ,@(let ((filename (massage (cadr expr))))
            (call-with-port
              (open-input-file filename)
              (lambda (port)
                (read-all/source port filename))))))))

(define-syntax include-ci
  (er-macro-transformer
   (lambda (expr rename compare)
    `(include ,@(cdr expr)))))

;; Convert a list read by the reader into an improper list
(define (->dotted-list lst)
  (cond
    ((null? lst) '())
    ((equal? (car lst) *sym-dot*)
     (cadr lst))
    (else
      (cons (car lst) (->dotted-list (cdr lst))))))
  
;; Main lexer/parser
(define read
  (lambda args
    (let ((fp (if (null? args)
                  (current-input-port)
                    (car args)))
          (ssi! (if (and (pair? args)
                         (pair? (cdr args)))
                    (cadr args)
                    #f)) ;; Default
          (fname (if (and (pair? args)
                          (pair? (cdr args))
                          (pair? (cddr args)))
                     (caddr args)
                     #f)))
      (let ((result (parse fp ssi! fname)))
        (if (Cyc-opaque? result)
          (read-error fp fname "unexpected closing parenthesis")
          result)))))

;; Read given file, collecting source location information so we
;; can give meaningful compiler error messages
(define (read-all/source port filename)
  (read-all port store-source-info! filename))

;; read-all -> port -> [objects]
(define (read-all . args)
  (let* ((fp (if (null? args)
                 (current-input-port)
                 (car args)))
         (ssi! (if (and (pair? args)
                        (pair? (cdr args)))
                   (cadr args)
                   #f)) ;; Default
         (fname (if (and ssi!
                         (pair? (cddr args)))
                    (caddr args)
                    #f)))
    (define (loop fp result)
      (let ((obj (read fp ssi! fname)))
        (if (eof-object? obj)
          (reverse result)
          (loop fp (cons obj result)))))
    (loop fp '())))

;;(define-c reading-from-file?
;;  "(void *data, int argc, closure _, object k, object port)"
;;  " object result = boolean_f;
;;    Cyc_check_port(data, port);
;;    if (((port_type *)port)->flags == 1) {
;;      result = boolean_t;
;;    }
;;    return_closcall1(data, k, result);")

(define-c read-token
  "(void *data, int argc, closure _, object k, object port)"
  " Cyc_io_read_token(data, k, port);")

(define-c read-error
  "(void *data, object _, int argc, object *args)"
  " object port = args[1];
    object filename = args[2];
    object msg = args[3];
    char buf[1024];
    port_type *p;
    Cyc_check_port(data, port);
    Cyc_check_str(data, msg);
    p = ((port_type *)port);
    if (Cyc_is_string(filename) == boolean_t) {
      snprintf(buf, 1023, \"at line %d, column %d of %s: %s\", 
             p->line_num, p->col_num, 
             string_str(filename), 
             string_str(msg));
    } else {
      snprintf(buf, 1023, \"at line %d, column %d: %s\", 
             p->line_num, p->col_num, string_str(msg));
    }
    Cyc_rt_raise_msg(data, buf);")

(define-c Cyc-opaque-eq?
  "(void *data, int argc, closure _, object k, object opq, object obj)"
  " if (Cyc_is_opaque(opq) == boolean_f) 
      return_closcall1(data, k, boolean_f);
    return_closcall1(data, k, equalp( opaque_ptr(opq), obj ));"
  "(void *data, object ptr, object opq, object obj)"
  " if (Cyc_is_opaque(opq) == boolean_f) 
      return(boolean_f);
    return(equalp( opaque_ptr(opq), obj ));")

(define-c Cyc-opaque-unsafe-eq?
  "(void *data, int argc, closure _, object k, object opq, object obj)"
  " return_closcall1(data, k, equalp( opaque_ptr(opq), obj ));"
  "(void *data, object ptr, object opq, object obj)"
  " return(equalp( opaque_ptr(opq), obj ));")

(define-c Cyc-opaque-unsafe-string?
  "(void *data, int argc, closure _, object k, object opq)"
  " return_closcall1(data, k, Cyc_is_string(opaque_ptr(opq)));"
  "(void *data, object ptr, object opq)"
  " return(Cyc_is_string(opaque_ptr(opq)));")

(define-c Cyc-opaque->string
  "(void *data, int argc, closure _, object k, object opq)"
  " return_closcall1(data, k, opaque_ptr(opq));"
  "(void *data, object ptr, object opq)"
  " return(opaque_ptr(opq));")

(define-c Cyc-opaque-unsafe-string->number
  "(void *data, int argc, closure _, object k, object opq)"
  " Cyc_string2number_(data, k, opaque_ptr(opq));")

(define-c Cyc-make-rect
  "(void *data, int argc, closure _, object k, object r, object i)"
  " Cyc_make_rectangular(data, k, r, i); ")

(define-c get-line-num 
  "(void *data, int argc, closure _, object k, object port)"
  " int num = ((port_type *)port)->line_num; 
   return_closcall1(data, k, obj_int2obj(num)); ")

(define-c get-col-num 
  "(void *data, int argc, closure _, object k, object port)"
  " int num = ((port_type *)port)->col_num; 
   return_closcall1(data, k, obj_int2obj(num)); ")

(define (store-source-info! obj filename line col) 
  (set! *reader-source-db* 
        (cons (cons obj (vector filename line col))
              *reader-source-db*)))
  ;; TODO: where to store? Need to use a hashtable but also needs to
  ;; be accessible from macro's. probably needs to be in global env,
  ;; see (cyclone foreign) for an example
;; TODO: need corresponding macro (syntax-error/source ??) to use this
;; information for error reporting
;; TODO: probably want to have a top-level exception handler on macro
;; expansion and call compiler error to report any error along with 
;; source info


;; Parse given input port and retrieve next token
;;
;; Params:
;;  fp - Input port
;;  ssi! - "Store Source Info" function, or #f if none
;;  fname - Filename being read, or #f if N/A
;;
;; Returns read token
(define (parse fp ssi! fname)
  (let ((token (read-token fp)))
    ;;(display "//")(write `(token ,token)) (newline)
    (cond
      ((Cyc-opaque? token)
       (cond
         ((Cyc-opaque-unsafe-string? token)
          (let ((rv (Cyc-opaque-unsafe-string->number token)))
            (if rv
                rv
                (error "Invalid numeric syntax" (Cyc-opaque->string token)))))
         ;; Open paren, start read loop
         ((Cyc-opaque-unsafe-eq? token #\()
          (let ((line-num (get-line-num fp))
                (col-num (get-col-num fp)))
            (let loop ((lis '())
                       (t (parse fp ssi! fname)))
              (cond
                ((eof-object? t)
                 (read-error fp fname "missing closing parenthesis"))
                ((Cyc-opaque-eq? t #\))
                 (if (and (> (length lis) 2)
                          (equal? (cadr lis) *sym-dot*))
                     (->dotted-list (reverse lis))
                     (let ((result (reverse lis)))
                       (when (and ssi!
                                  (pair? result)
                                  (symbol? (car result)))
                         ;; Possible macro expansion, save source info
                         (ssi! result 
                               fname 
                               line-num 
                               (- col-num 1))) ;; Account for open paren
                       result)))
                (else
                 (loop (cons t lis) (parse fp ssi! fname)))))))
         ((Cyc-opaque-unsafe-eq? token #\')
          (list 'quote (parse fp ssi! fname)))
         ((Cyc-opaque-unsafe-eq? token #\`)
          (list 'quasiquote (parse fp ssi! fname)))
         ((Cyc-opaque-unsafe-eq? token #\,)
          (list 'unquote (parse fp ssi! fname)))
         (else
          token))) ;; error if this is returned to original caller of parse
      ((vector? token)
       (cond
        ((= (vector-length token) 3) ;; Special case: exact/inexact number
         (if (vector-ref token 2)
             (exact (string->number (vector-ref token 0) (vector-ref token 1)))
             (inexact (string->number (vector-ref token 0) (vector-ref token 1)))))
        ((= (vector-length token) 2) ;; Special case: special symbols
         (let ((t (vector-ref token 0)))
           (cond
             ((eq? t *sym-unquote-splicing*)
              (list 'unquote-splicing (parse fp ssi! fname)))
             ((eq? t *sym-datum-comment*)
              (parse fp ssi! fname) ;; Ignore next datum
              (parse fp ssi! fname))
             ((string? t) ;; Special case: complex number
              (let* ((end (vector-ref token 1))
                     (len (string-length t))
                     (only-imag? (= (+ 1 end) len)) ;; EG: "57i" with no real component
                     (real-str (if only-imag?
                                   "0"
                                   (substring t 0 end)))
                     (imag-str (if only-imag?
                                   (substring t 0 end)
                                   (substring t end (- len 1))))
                     (real (string->number real-str))
                     (imag (cond
                             ((equal? "+" imag-str) 1)  ;; Special case, +i w/no number
                             ((equal? "-" imag-str) -1) ;; Special case, -i
                             (else (string->number imag-str))))
                    )
                (Cyc-make-rect real imag)))
             (else
              (error "Unexpected token" t)))))
        ((= (vector-length token) 1) ;; Special case: error
         (error (vector-ref token 0)))
        (else
         (let loop ((lis '())
                    (t (parse fp ssi! fname)))
           (cond
             ((eof-object? t)
              (read-error fp fname "missing closing parenthesis"))
             ((Cyc-opaque-eq? t #\))
              (list->vector (reverse lis)))
             (else
              (loop (cons t lis) (parse fp ssi! fname))))))))
      ((bytevector? token)
       (let loop ((lis '())
                  (t (parse fp ssi! fname)))
         (cond
           ((eof-object? t)
            (read-error fp fname "missing closing parenthesis"))
           ((Cyc-opaque-eq? t #\))
            (apply bytevector (reverse lis)))
           (else
            (loop (cons t lis) (parse fp ssi! fname))))))
      (else
        token))))
  ))