#| -*-Scheme-*-

$Id: camel-case.scm 7464 2007-11-30 19:08:36Z cph $

Copyright (C) 2006,2007 Massachusetts Institute of Technology

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.

|#

;;;; Camel-case support

(declare (usual-integrations))

(define (camel-case->lisp object)
  (let ((f
	 (lambda (string)
	   (call-with-input-string string
	     (lambda (input)
	       (port/set-coding input 'utf-8)
	       (call-with-output-string
		 (lambda (output)
		   (port/set-coding output 'utf-8)
		   (let loop ((prev #f))
		     (let ((c (read-char input)))
		       (if (not (eof-object? c))
			   (begin
			     (if (and prev
				      (char-upper-case? c)
				      (or (char-lower-case? prev)
					  (char-numeric? prev)
					  (and (char-upper-case? prev)
					       (let ((c (peek-char input)))
						 (and (char? c)
						      (char-lower-case? c))))))
				 (write-char #\- output))
			     (write-char (char-downcase c) output)
			     (loop c))))))))))))
    (cond ((string? object) (f object))
	  ((symbol? object) (utf8-string->symbol (f (symbol-name object))))
	  (else
	   (error:wrong-type-argument object "symbol" 'camel-case->lisp)))))