;;; Copyright (c) 2019 David Ireland.  All rights reserved.
;;; BSD 3-Clause License: http://opensource.org/licenses/BSD-3-Clause
;;;
;;; Shen Scheme derived soure code is:
;;; Copyright (c) 2012-2015 Bruno Deferrari.  All rights reserved.

(import
  srfi-13
  srfi-69
  chicken.format
  chicken.process-context)

(include "klambda.scm")

;;; Define a custom port because Chicken Scheme doesn't have unread-char which
;;; is a convenient procedure when parsing K-λ
(define (string->custom-port str)
  (define characters (string->list str))
  (define last-read  #!eof)
  (lambda (cmd)
    (cond
     ((equal? unread-char: cmd)
      (set! characters (cons last-read characters)))
     ((equal? peek-char: cmd)
      (if (pair? characters)
	  (car characters)
	  #!eof))
     ((equal? read-char: cmd)
      (if (pair? characters)
	  (let ((ret (car characters)))
	    (set! characters (cdr characters))
	    (when (not (eof-object? ret))
	      (set! last-read ret))
	    ret)
	  #!eof))
     (else
      (error "custom-port can't handle " cmd)))))

(define (pretty x)
  (if (list? x)
      (begin
	(print "(")
	(for-each
	 (lambda (y)
	   (if (list? y)
	       (pretty y)
	       (begin
		 (print (sprintf "~S" y))
		 (print " ")))) x)
	(print ") "))
      (begin
	(print (format x)) (print " "))))

(define (digit? char)
  (pair?
   (member char '(#\0 #\1 #\2 #\3 #\4
		  #\5 #\6 #\7 #\8 #\9))))

;;; From https://rosettacode.org/wiki/S-Expressions#Scheme
;;; Parses K-λ syntax with a custom port that includes unread-char
(define (sexpr-read port)
  (define (help port)
    (let* ((char (port read-char:)))
      (cond
       ((or (eof-object? char)
	    (eq? char #\) ))
	'())
       ((eq? char #\( )
	(let ((lhs (help port))
	      (rhs (help port)))
          (cons lhs rhs)))
       ((char-whitespace? char)
	(help port))
       ((eq? char #\")
	(cons (quote-read port)
	      (help port)))
       ;;; Negative number
       ((and (eq? char #\-)
	     (digit? (port peek-char:)))
       	(cons (* -1 (number-read port))
	      (help port)))
       ((digit? char)
	(port unread-char:)
	(let ((lhs (number-read port))
	      (rhs (help port)))
	  (cons lhs rhs)))
       (else
	(port unread-char:)
	(let ((lhs (string-read port))
	      (rhs (help port)))
	  (cons lhs rhs))))))
  
;;; This is needed because the function conses all parsed sexprs
;;; onto something, so the top expression is one level too deep.
  
  (let ((result (help port)))
    (if (null? result)
	result
	(car result))))

(define (quote-read port)
  (define (help port)
    (let ((char (port read-char:)))
      (if (or (eof-object? char)
	      (eq? char #\" ))
	  '()
	  (cons char (help port)))))
  (list->string (help port)))

(define (string-read port)
  (define (help port)
    (let ((char (port read-char:)))
      (cond
       ((or (eof-object? char)
	    (char-whitespace? char))
	'())
       ((eq? char #\) )
	(port unread-char:)
	'())
       (else
	(cons char (help port))))))
  (kl:intern (list->string (help port))))

(define (number-read port)
  (define (help port)
    (let ((char (port read-char:)))
      (cond
       ((or (eof-object? char)
	    (char-whitespace? char))
	'())
       ((eq? char #\) )
	(port unread-char:)
	'())
       ;;; Real number (floating point)
       ((eq? char #\. )
	(cons char (help port)))
       ((not (digit? char))
	(port unread-char:)
	'())
       (else
	(cons char (help port))))))
  
  (let ((result (list->string (help port))))
    (string->number result)))

(define (write-lisp-file path data)
  (with-output-to-file path
    (lambda ()
      (for-each
       (lambda (s)
	 (format #t "~S" s)
	 (format #t  "~%"))
       data))))

(define (read-file path)
  (list->string
   (call-with-input-file path
     (lambda (p)
       (let more ((x (read-char p)))
	 (if (eof-object? x)
	     '()
	     (cons x (more (read-char p)))))))))
    
(define (read-kl-file path)
  (let* ((data (read-file path))
 	 (port (string->custom-port
		(string-append "("  data  ")" ))))
     (sexpr-read port)))


(define kl-files
  '("toplevel.kl"
    "core.kl"
    "sys.kl"
    "sequent.kl"
    "yacc.kl"
    "reader.kl"
    "prolog.kl"
    "track.kl"
    "load.kl"
    "writer.kl"
    "macros.kl"
    "dict.kl"
    "declarations.kl"
    "types.kl"
    "t-star.kl"))

(define (compile-all)
  (for-each
   (lambda (file)
     (print "Compiling Shen (Kλ) to Chicken Scheme: "  file)
     (let* ((compiled-name (string-append "shen-chicken/" file))
	    (module-name   (string->symbol compiled-name))
	    (kl-file       (read-kl-file (string-append "shen-kl/" file))))
       (write-lisp-file
	(string-append compiled-name ".scm")
	`(,@(map kl->scheme kl-file)))))
   kl-files))
  
(compile-all)