;; Author: David Krentzlin <david@lisp-unleashed.de>
;; Copyright (c) 2011 David Krentzlin <david@lisp-unleashed.de>
;; 
;;   Permission is hereby granted, free of charge, to any person
;;   obtaining a copy of this software and associated documentation
;;   files (the "Software"), to deal in the Software without
;;   restriction, including without limitation the rights to use,
;;   copy, modify, merge, publish, distribute, sublicense, and/or sell
;;   copies of the Software, and to permit persons to whom the
;;   Software is furnished to do so, subject to the following
;;   conditions:
;; 
;;   The above copyright notice and this permission notice shall be
;;   included in all copies or substantial portions of the Software.
;; 
;;   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;   EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
;;   OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;   NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;   HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;   WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
;;   OTHER DEALINGS IN THE SOFTWARE.
;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(module simple-configuration
(config-ref config-let config-read)
(import chicken scheme extras files
        (only posix current-directory)
        (only data-structures alist-ref identity conc))

(define (absolutize-path path)
  (let ((cwd (current-directory)))
    (if (absolute-pathname? path)
        (normalize-pathname path)
        (normalize-pathname (conc cwd "/" path)))))

;;post-process is applied even to default-value
(define (config-ref cfg path #!key (default #f) (post-process identity))
  (post-process
   (cond
    ((null? cfg) default)
    ((null? path)
     (if (list? cfg)
         (if (> (length cfg) 1)
             cfg
             (car cfg))
         default)) 
    ((alist-ref (car path) cfg)
     => (lambda (new-cfg)
          (config-ref new-cfg (cdr path) default: default)))
    (else default))))

(define-syntax config-let
  (syntax-rules ()
    ((_ cfg ((var (path path+ ...)) ...) body body+ ...)
     (let ((var (config-ref cfg '(path path+ ...))) ...)
       body
       body+
       ...))))

(define (config-read port-or-path #!key (eval-config #f))
  (unless (or (port? port-or-path) (string? port-or-path))
    (error 'config-read "Argument must be either a port or a string") port-or-path)
  (let ((content
         (if (port? port-or-path)
             (read port-or-path)
             (let ((path (absolutize-path port-or-path)))
               (unless (file-exists? path)
                 (error 'config-read "The configfile does not exist" path))
               (with-input-from-file port-or-path read)))))
    (if eval-config
        (eval (cons 'quasiquote (cons  content '())))
        content)))

)