; 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-module (sugar))

(define-public group 'group)

(define-public sugar-save #f)

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

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

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

(define (readblocks level port)
  (let* ((read (readblock-clean level port))
	 (next-level (car read))
	 (block (cdr read)))
    (if (= next-level level)
	(let* ((reads (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 (readblock level port)
  (let ((next-read (readline port))
	(next-level (indentationlevel port)))
    (if (null? next-read)
	(cons next-level next-read)
	(if (> next-level level)
	    (let* ((next-next-read (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 (readblock-clean level port)
  (let* ((read (readblock level port))
	 (next-level (car read))
	 (block (cdr read)))
    (if (= (length block) 1)
	(cons next-level (car block))
	(cons next-level (clean block)))))

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

(define-public (sugar-enable)
  (set! sugar-save read)
  (set! read sugar-read))

(define-public (sugar-disable)
  (set! read sugar-save))

(sugar-enable)