; Sugar version redhog.0
; Copyright (C) 2000 by MandrakeSoft
; RedHog (Egil Möller) <redhog@lysator.liu.se>
; This library is free software; you can redistribute it and/or
; modify it under the terms of the GNU Library General Public
; License as published by the Free Software Foundation; either
; version 2 of the License, or (at your option) any later version.
;
; This library 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
; Library General Public License for more details.
;
; You should have received a copy of the GNU Library General Public
; License along with this library; if not, write to the
; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
; Boston, MA  02111-1307, USA.
;
; The syntax is perheaps best exaplained by examples:
;
; The fabulous faculty function (x!)
;
; define
;  fac x
;  if
;   = x 0
;   1
;   * x
;     fac
;      - x 1
;
; Of course, you can put normal LISP-expressios in the middle of
; sugar-expressions!
;
; Anyway, there is a special symbol, group, which, if written first at a
; line, is removed. This allows for example the following:
;
; let
;  group
;   foo
;    + 1 2
;   bar
;    + 3 4
;  + foo bar

(define sugar-save read)
(define group 'group)

(define (sugar-indentationlevel port)
  (define (indentationlevel level)
    (if (eq? (peek-char port) #\space)
	(begin
	  (read-char port)
	  (indentationlevel (+ level 1)))
	level))
  (indentationlevel 0))

(define (sugar-readline port)
  (let ((char (peek-char port)))
    (cond
     ((eq? char #\newline)
      (read-char port)
      '())
     ((or (eq? char #\space)
	  (eq? char #\ht))
      (read-char port)
      (sugar-readline port))
     (t
      (cons (sugar-save port) (sugar-readline port))))))

(define (sugar-clean line)
  (cond
   ((null? line)
    line)
   ((eq? (car line) 'group)
    (cdr line))
   ((null? (car line))
    (cdr line))
   ((list? (car line))
    (cons
     (sugar-clean (car line))
     (cdr line)))
   (#t
    line)))

(define (sugar-readblocks level port)
  (let* ((read (sugar-readblock-clean level port))
	 (next-level (car read))
	 (block (cdr read)))
    (if (= next-level level)
	(let* ((reads (sugar-readblocks level port))
	       (next-next-level (car reads))
	       (next-blocks (cdr reads)))
	  (cons next-next-level (cons block next-blocks)))
	(cons next-level (list block)))))

(define (sugar-readblock level port)
  (let ((next-read (sugar-readline port))
	(next-level (sugar-indentationlevel port)))
    (if (null? next-read)
	(cons next-level next-read)
	(if (> next-level level)
	    (let* ((next-next-read (sugar-readblocks next-level port))
		   (next-next-level (car next-next-read))
		   (next-rest-block (cdr next-next-read)))
	      (cons next-next-level (append next-read next-rest-block)))
	    (cons next-level next-read)))))

(define (sugar-readblock-clean level port)
  (let* ((read (sugar-readblock level port))
	 (next-level (car read))
	 (block (cdr read)))
    (if (= (length block) 1)
	(cons next-level (car block))
	(cons next-level (sugar-clean block)))))

(define (sugar . port)
  (if (null? port)
      (cdr (sugar-readblock-clean 0 (current-input-port)))
      (cdr (sugar-readblock-clean 0 (car port)))))

(set! read sugar)