(load "./flisp/aliases.scm")
(load "./flisp/profile.scm")
(load "utils.scm")
(load "ast.scm")
(load "match.scm")
(load "macroexpand.scm")
(load "julia-parser.scm")
(load "julia-syntax.scm")


;; exception handler to turn known errors into special expressions,
;; to prevent throwing an exception past a C caller.
(define (error-wrap thk)
  (with-exception-catcher
   (lambda (e)
     (if (and (pair? e) (eq? (car e) 'error))
         (let ((msg (cadr e))
               (pfx "incomplete:"))
           (if (and (string? msg) (>= (string-length msg) (string-length pfx))
                    (equal? pfx
                            (substring msg 0 (string-length pfx))))
               `(incomplete ,msg)
               e))
         (begin
           ;;(newline)
           ;;(display "unexpected error: ")
           ;;(prn e)
           ;;(print-stack-trace (stacktrace))
           '(error "malformed expression"))))
   thk))


;; return a lambda expression representing a thunk for a top-level expression
;; note: expansion of stuff inside module is delayed, so the contents obey
;; toplevel expansion order (don't expand until stuff before is evaluated).
(define (expand-toplevel-expr-- e file line)
  (let ((ex0 (julia-expand-macroscope e)))
    (if (toplevel-only-expr? ex0)
        ex0
        (let* ((ex (julia-expand0 ex0))
               (th (julia-expand1
                    `(lambda () ()
                             (scope-block
                              ,(blockify ex)))
                    file line)))
          (if (and (null? (cdadr (caddr th)))
                   (and (length= (lam:body th) 2)
                        (let ((retval (cadadr (lam:body th))))
                          (or (and (pair? retval) (eq? (car retval) 'lambda))
                              (simple-atom? retval)))))
              ;; generated functions use the pattern (body (return (lambda ...))), which
              ;; needs to be unwrapped to just the lambda (CodeInfo).
              (cadadr (lam:body th))
              `(thunk ,th))))))

(define *in-expand* #f)

(define (toplevel-only-expr? e)
  (and (pair? e)
       (or (memq (car e) '(toplevel line module import using export
                                    error incomplete))
           (and (memq (car e) '(global const)) (every symbol? (cdr e))
                (every (lambda (x) (not (memq x '(true false)))) (cdr e))))))

(define (expand-toplevel-expr e file line)
  (cond ((or (atom? e) (toplevel-only-expr? e))
         (if (underscore-symbol? e)
             (error "all-underscore identifier used as rvalue"))
         e)
        (else
         (let ((last *in-expand*))
           (if (not last)
               (begin (reset-gensyms)
                      (set! *in-expand* #t)))
           (begin0 (expand-toplevel-expr-- e file line)
                   (set! *in-expand* last))))))

;; construct default definitions of `eval` for non-bare modules
;; called by jl_eval_module_expr
(define (module-default-defs e)
  (jl-expand-to-thunk
   (let* ((name (caddr e))
          (body (cadddr e))
          (loc  (cadr body))
          (loc  (if (and (pair? loc) (eq? (car loc) 'line))
                    (list loc)
                    '()))
          (x    (if (eq? name 'x) 'y 'x)))
     `(block
       (= (call eval ,x)
          (block
           ,@loc
           (call (core eval) ,name ,x)))
       (= (call include ,x)
          (block
           ,@loc
           (call (top include) ,name ,x)))))
   'none 0))

;; parse one expression (if greedy) or atom, returning end position
(define (jl-parse-one s pos0 greedy)
  (let ((inp (open-input-string s)))
    (io.seek inp pos0)
    (let ((expr (error-wrap (lambda ()
                              (if greedy
                                  (julia-parse inp)
                                  (julia-parse inp parse-atom))))))
      (cons expr (io.pos inp)))))

(define (parse-all- io filename)
  (unwind-protect
   (with-bindings ((current-filename (symbol filename)))
    (let ((stream (make-token-stream io)))
      (let loop ((exprs '()))
        (let ((lineno (error-wrap
                       (lambda ()
                         (skip-ws-and-comments (ts:port stream))
                         (input-port-line (ts:port stream))))))
          (if (pair? lineno)
              (cons 'toplevel (reverse! (cons lineno exprs)))
              (let ((expr (error-wrap
                           (lambda ()
                             (julia-parse stream)))))
                (if (eof-object? expr)
                    (cons 'toplevel (reverse! exprs))
                    (let* ((iserr  (and (pair? expr) (eq? (car expr) 'error)))
                           ;; for error, get most recent line number (#16720)
                           (lineno (if iserr (input-port-line io) lineno))
                           (next   (list* expr
                                          ;; include filename in first line node
                                          (if (null? exprs)
                                              `(line ,lineno ,(symbol filename))
                                              `(line ,lineno))
                                          exprs)))
                      (if iserr
                          (cons 'toplevel (reverse! next))
                          (loop next))))))))))
   (io.close io)))

;; parse all expressions in a string, the same way files are parsed
(define (jl-parse-all str filename)
  (parse-all- (open-input-string str) filename))

(define (jl-parse-file filename)
  (trycatch
   (parse-all- (open-input-file filename) filename)
   (lambda (e) #f)))

; expand a piece of raw surface syntax to an executable thunk
(define (jl-expand-to-thunk expr file line)
  (error-wrap (lambda ()
                (expand-toplevel-expr expr file line))))

(define (jl-expand-to-thunk-stmt expr file line)
  (jl-expand-to-thunk (if (toplevel-only-expr? expr)
                          expr
                          `(block ,expr (null)))
                      file line))

(define (jl-expand-macroscope expr)
  (error-wrap (lambda ()
                (julia-expand-macroscope expr))))

; run whole frontend on a string. useful for testing.
(define (fe str)
  (expand-toplevel-expr (julia-parse str) 'none 0))

(define (profile-e s)
  (with-exception-catcher
   (lambda (e)
           (newline)
           (prn e))
   (lambda () (profile s))))


; --- logging ---
; Utilities for logging messages from the frontend, in a way which can be
; controlled from julia code.

; Log a general deprecation message at line node location `lno`
(define (deprecation-message msg lno)
  (let* ((lf (extract-line-file lno)) (line (car lf)) (file (cadr lf)))
    (frontend-depwarn msg file line)))

; Log a syntax deprecation from line node location `lno`
(define (syntax-deprecation what instead lno)
  (let* ((lf (extract-line-file lno)) (line (car lf)) (file (cadr lf)))
    (deprecation-message (format-syntax-deprecation what instead file line #f) lno)))

; Extract line and file from a line number node, defaulting to (0, none)
; respectively if lno is absent (`#f`) or doesn't contain a file
(define (extract-line-file lno)
  (cond ((or (not lno) (null? lno)) '(0 none))
        ((not (eq? (car lno) 'line)) (error "lno is not a line number node"))
        ((length= lno 2) `(,(cadr lno) none))
        (else (cdr lno))))

(define (format-loc lno)
  (let* ((lf (extract-line-file lno)) (line (car lf)) (file (cadr lf)))
    (format-file-line file line #f)))

(define (format-file-line file line exactloc)
  (if (or (= line 0) (eq? file 'none))
      ""
      (string (if exactloc " at " " around ") file ":" line)))

(define (format-syntax-deprecation what instead file line exactloc)
  (string "Deprecated syntax `" what "`"
          (format-file-line file line exactloc)
          "."
          (if (equal? instead "") ""
              (string #\newline "Use `" instead "` instead."))))

; Corresponds to --depwarn 0="no", 1="yes", 2="error"
(define *depwarn-opt* 1)

; Emit deprecation warning via julia logging layer.
(define (frontend-depwarn msg file line)
  ; (display (string msg "; file = " file "; line = " line #\newline)))
  (case *depwarn-opt*
    (1 (julia-logmsg 1000 'depwarn (symbol (string file line)) file line msg))
    (2 (error msg))))