#! /usr/bin/guile-@guile_version@ \
-e main -s
!#

;; Copyright (C) 2008-2018 Tommi Höynälänmaa
;; Distributed under GNU General Public License version 3,
;; see file doc/GPL-3.


(import (rnrs exceptions))
(import (theme-d common theme-d-config))
(import (theme-d testing test-info))


(define gl-extra-flags "--pretty-print")

(init-theme-d-config)

(define gl-theme-d-compiler-path
  (get-theme-d-config-var 'compiler-path))


(define (get-test-name i)
  (string-append "test" (number->string i)))


(define (get-source-ext unit-type)
  (case unit-type
    ((interface) ".thi")
    ((body) ".thb")
    ((proper-program) ".thp")
    ((script) ".ths")
    (else (raise 'invalid-unit-type))))


(define (get-target-ext unit-type)
  (case unit-type
    ((interface) ".tci")
    ((body) ".tcb")
    ((proper-program) ".tcp")
    ((script) ".tcs")
    (else (raise 'invalid-unit-type))))


(define (get-source-filename i unit-type)
  (let ((ext (get-source-ext unit-type)))
    (string-append "test" (number->string i) ext)))


(define (get-target-filename i unit-type)
  (let ((ext (get-target-ext unit-type)))
    (string-append "test" (number->string i) ext)))


(define (get-test-path filename)
  (string-append "../theme-d-code/tests/" filename))


(define (get-unit-type-string unit-type)
  (case unit-type
    ((proper-program) "proper program")
    ((script) "script")
    ((interface) "interface")
    ((body) "body")
    (else (raise 'internal-error))))


(define (compile-unit index unit-type output-file)
  (let ((source-filename (get-source-filename index unit-type))
	(target-filename (get-target-filename index unit-type)))
    (let ((source-path (get-test-path source-filename))
	  (target-path (get-test-path target-filename)))
      (display (string-append "Compiling " (get-unit-type-string unit-type)
			      " "))
      (display source-filename)
      (newline)
      (flush-all-ports)
      (let ((result		   
	     (system (string-append
		      gl-theme-d-compiler-path
		      " -m :../theme-d-code -o "
		      target-path " "
		      gl-extra-flags " " source-path " 2>&1"))))
	(if (= result 0)
	    (begin
	      (display (string-append "Compilation of " (symbol->string unit-type) " ") output-file)
	      (display source-filename output-file)
	      (display " succeeded." output-file)
	      (newline output-file))
	    (begin
	      (display "Compilation of " output-file)
	      (display source-filename output-file)
	      (display " failed." output-file)
	      (newline output-file)))))))


(define (compile-components unit-type output-file)
  (do ((cur-modules modules (cdr cur-modules))) ((null? cur-modules))
    (let ((i-cur (car cur-modules)))
	(compile-unit i-cur unit-type output-file))))

(define (compile-programs output-file)
  (do ((i 1 (+ i 1))) ((> i nr-of-tests))
    (if (not (member i modules))
	(let ((unit-type
	       (if (member i scripts) 'script 'proper-program)))
	  (compile-unit i unit-type output-file)))))

(define (main args)
  (call-with-output-file "compile-tests.log"
    (lambda (output-file)
      (compile-components 'interface output-file)
      (compile-components 'body output-file)
      (compile-programs output-file))))
