;--------------------------------------------------------------------------
; sh.kl
;
; An error corrector that triggers a shell call on UndefinedFunction
; An experiment...
;--------------------------------------------------------------------------

;; This variable holds the shell command to be invoked :
 
(require 'closure)
(setq *sh:current-command* ())

;--------------------------------------------------------------------------
; shell:invoke invoke the command.
;
; This is fancy: if some redirection is needed, the shell command
; command will be launched in background, otherwise, it will be encapsulated
; in a wait.
;--------------------------------------------------------------------------

(defunq sh:invoke (sh:current-command &rest args)
  ;; Test for :input, or :output keywords, removing them
  (with (sh:args       (list)
      sh:input      ()
      sh:output     ()
      index            0
      lindex           (length args))
    (while (< index lindex)
      (if (and (= (get args index) ':input) (< (++ index) lindex))
	(setq sh:input (eval (get args index)))
	(and (= (get args index) ':output) (< (++ index) lindex))
	(setq sh:output (eval (get args index)))
	t
	(setq sh:args (+ sh:args (list (get args index)))))
      (++ index))
    (setq *sh:last-command* (+ (list sh:current-command) sh:args))
    (if (and sh:input sh:output)
      (system *sh:last-command* :input sh:input :output sh:output)
      sh:input
      (system *sh:last-command* :input sh:input)
      sh:output
      (system *sh:last-command* :output sh:output)
      t
      (wait (system *sh:last-command*)))) )

;; Is this a catchable shell function ?
(setq sh:catchable-re  (regcomp "^sh:\(.*\)"))

(defunq sh:error-corrector (err &rest data)
  (if
    (= err 'Errors:UndefinedFunction)
    (with (function (get data 0))
      (if (and (typep function Atom) (regexec sh:catchable-re function))
	(closure sh:invoke (regsub sh:catchable-re "\\1"))
	:nil
    ))
    :nil
))

;; Initialize: add this corrector to klone std correctors if not already here

(if (not (seek *error-correctors* 'sh:error-corrector))
  (put *error-correctors* -1 'sh:error-corrector)
)

