#!/bin/sh
exec ${GUILE-guile} -e '(ttn-do demo)' -s $0 "$@" # -*-scheme-*-
!#
;;; demo --- display demos defined in ~/.demos

;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2009, 2010,
;;   2011 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version.  There is NO WARRANTY.  See file COPYING for details.

;;; Commentary:

;; Usage: demo [NAME...]
;;
;; Consult ~/.demos for a list of demos, and run each demo named.
;; If more than one NAME is specified, display "running demo: NAME"
;; prior to running the demo.  If NAME is omitted, simply list the
;; available demos.
;;
;; The ~/.demos file contains normal Scheme code, interspersed w/
;; expressions of the form:
;;
;;   (defdemo NAME (child FILENAME [ARGS...]))
;;
;; The ‘defdemo’ form registers a thunk under NAME in the demo list.
;; The ‘child’ procedure returns a thunk suitable for running demo
;; FILENAME w/ ARGS, after first changing to FILENAME's directory.

;;; Code:

(define-module (ttn-do demo)
  #:export (main)
  #:use-module ((ice-9 rdelim) #:select (write-line))
  #:use-module ((ice-9 rw) #:select (read-string!/partial))
  #:use-module ((ttn-do zzz banalities) #:select (check-hv))
  #:use-module ((ttn-do zzz personally) #:select (accumulator
                                                  FE fs fso))
  #:use-module ((ttn-do zzz filesystem)
                #:select ((expand-file-name-substituting-env-vars
                           . resolve-dir))))

(define *defs-file* (in-vicinity (getenv "HOME") ".demos"))

(define *demos* (accumulator))

(define-macro (defdemo name . body)
  `(*demos* (cons ',name (lambda () ,@body))))

(define (child filename . args)
  ;; ARGS can be a list of strings, or a thunk (evaluated after changing
  ;; directory to DIR) that returns a list of strings.
  (let ((pid (primitive-fork)))
    (if (zero? pid)
        (let* ((program (fs "./~A" (basename filename)))
               (new-command-line (cons program
                                       (if (and (not (null? args))
                                                (thunk? (car args)))
                                           ((car args))
                                           args)))
               (buf (make-string 128 #\space))
               (check (lambda (rx) (regexp-exec (make-regexp rx) buf))))
          (chdir (resolve-dir (dirname filename)))
          (read-string!/partial buf (open-input-file program))
          ;; peek inside and vary invocation accordingly
          (cond ((and (access? program X_OK)
                      (or (not (check "\n!#"))
                          (check "[ \n]-e ..*\n!#") buf))
                 (apply execl program new-command-line))
                (else
                 (set! command-line (lambda () new-command-line))
                 (load-from-path program)
                 (exit #t))))
        (waitpid pid))))

;; load all the demo definitions
(primitive-load *defs-file*)

;; everything else

(define (main/args args)
  (cond ((= 1 (length args))
         (FE (map car (*demos*)) write-line)
         (exit #t)))
  (let ((only-one? (= 2 (length args)))
        (me (car args))
        (c-n-f-d "could not find demo:")
        (exit-val #t))                  ; optimism is ok sometimes
    (FE (map string->symbol (cdr args))
        (lambda (name)
          (let ((demo (assq-ref (*demos*) name)))
            (cond ((thunk? demo)
                   (or only-one?
                       (fso "~A: running demo: ~A~%" me name))
                   (demo))
                  (only-one?
                   (error c-n-f-d name))
                  (else
                   (fso "~A: ~A ~A~%" me c-n-f-d name)
                   (set! exit-val #f))))))
    exit-val))

(define (main args)
  (check-hv args '((package . "ttn-do")
                   ;; 1.0 -- plain
                   ;; 1.1 -- if "-e" in program header, do ‘execl’
                   ;; 2.0 -- concise ‘child’ syntax, env vars expanded,
                   ;;        handle shell scripts
                   ;; 2.1 -- bugfix: don't execl if not X_OK
                   (version . "2.1")
                   (help . commentary)))
  (main/args args))

;;; demo ends here