#!/usr/bin/guile -s
!#
(use-modules (ice-9 debug))


(define datadir "../common/")
(define old-backend-dir "/usr/lib/alterator/backend")
(define new-backend-dir "/usr/lib/alterator/backend2")

(load (string-append datadir "str.scm"))
(load (string-append datadir "pipe.scm"))
(load (string-append datadir "woobus.scm"))
(load (string-append datadir "dynload.scm"))
(load (string-append datadir "barnacle.scm"))
(load (string-append datadir "command.scm"))
(load (string-append datadir "command-compat.scm"))

;filter: split command name, convert args to associative list
(define (prepare-cmds cmds)
  (let loop ((result '())
	     (cmds cmds))
    (cond
      ((null? cmds) result)
      ((null? (car cmds)) (loop result (cdr cmds))) ;ignore null commands
      ((not (pair? (car cmds))) (error "invalid command in list"))
      ((eq? (caar cmds) '#{}#) (loop result (cdr cmds))); also ignore empty commands
      (else
	(let ((current (car cmds)))
	  (loop (append result 
			(list (cons (string-split (sure-string (car current)) #\/)
				    (command-fold acons '() current))))
		(cdr cmds)))))))

;input to easy to use lists
(define (in) (prepare-cmds (message->commands (read-bus '>>))))

;default backend for all commands: always answers - "backend not found"
(define (ghost-mariner object action)
  (lambda args  '(error "backend not found")))

(define (null-mariner object action)
  (lambda args #f))

(define (read-midshipman-file)
  (let loop ((x (read))
	     (res '()))
    (cond
      ((eof-object? x) res)
      ((and (pair? x) (eq? 'lambda (car x))) (append res (list x)))
      ((and (pair? x) (eq? 'define (car x))) (loop (read) (append res (list x))))
      (else (loop (read) res)))))

(define (load-midshipman sym file)
  (let ((midshipman (with-input-from-file file read-midshipman-file)))
    (and (not (null? midshipman))
	 (eval `(define (make-midshipman) ,@midshipman) (current-module))
	 (eval `(define ,sym (make-midshipman)) (current-module)))))


;try to load an appropriate backend
;temporary DEMO: always return ghost mariner
(define (load-mariner sym continue)
  (let ((old-backend (string-append old-backend-dir "/" (sure-string sym)))
	(new-backend (string-append new-backend-dir "/" (sure-string sym))))
    (cond
      ((eq? sym 'ctrl) (continue 'null-mariner))
      ((access? new-backend R_OK) (if (load-midshipman sym new-backend)
				    (continue sym)
				    (continue 'ghost-mariner)))
      ((access? old-backend R_OK) (eval `(define ,sym (lambda (objects action)
							(barnacle ,old-backend objects action)))
					(current-module))
				  (continue sym))
      (else (continue 'ghost-mariner)))))

(define (resolv-name sym)
  (dynload sym (lambda (sym) (eval sym (current-module))) load-mariner))

(define (sure-symbol sym)
  (cond 
    ((symbol? sym) sym)
    ((string? sym) (string->symbol sym))
    (else (error "sure-symbol: unsupported type" sym))))

;load low-level backend
(define (call-mariner cmd)
    (let ((name (car cmd))
	(args (cdr cmd)))
    (if (not (null? name))
      (let ((mariner (resolv-name (sure-symbol (car name))))
	    (action  (assoc 'action args)))
	(if action
	  ((mariner (cdr name) (sure-symbol (cdr action))) args)
	  '(error "action field not found" cmd))))))

(define (error-answer? cmd) (and (pair? cmd) (eq? (car cmd) 'error)))


;process commands from list and autoconvert results
(define (process-command cmd)
  (define (write-error name reason)
    (write-command `(,(string-append "/error" name) reason ,reason)))
  (define (write-multiple-commands name cmds)
    (for-each (lambda (x) (write-command (list (string-append name "/" (car x))))) cmds))
  (let ((name (string-append "/" (string-join (car cmd) "/")))
	(answer (call-mariner cmd)))
    (if answer
      (cond
	((null? answer) '()); empty answer
	((error-answer? answer) (write-error name (cadr answer)))
	((and (pair? answer) (pair? (car answer))) (write-multiple-commands name answer))
	((pair? answer) (write-command `(,name ,@answer)))
	(else
	  (write-error name "unsupported answer type"))))))
	
(define (process cmds)
  (wait-accept backward-address)
  (for-each process-command cmds)
  (write-line end-of-message)
  (force-output (current-output-port)))

(define (main)
  (process (in))
  (main))

(main)

