;;
;;  A parser for I-expressions (based on SRFI-49)
;;
;; Copyright 2010-2011 Ivan Raikov and the Okinawa Institute of
;; Science and 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 3 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.
;;
;; A full copy of the GPL license can be found at
;; <http://www.gnu.org/licenses/>.
;;


(module iexpr

	(parse tree-empty? tree-level tree-child tree-sibling tree->list)

	(import scheme chicken )
	(require-library srfi-1)
	(import 
	 (only extras fprintf)
	 (only data-structures conc identity compose))
	(require-extension datatype)

(define-record token symbol value line)

(define-record-printer (token x out)
  (fprintf out "#(token  ~S ~S)"
	   (token-symbol x)
	   (token-value x) ))

(define (token p line)
  (cons (car p)
	(cond  [(pair? (cdr p))  (make-token (car p) (cadr p) line)]
	       [else (make-token (car p) #f line)])))

(define-syntax tok
  (syntax-rules ()
    ((tok t)   (token (quasiquote t) 0))
    ((tok t l) (token (quasiquote t) l))))

(define (make-parse-error loc)
  (lambda (msg #!optional arg)
    (let ((loc-str (or (and loc (if (list? loc) (conc " " loc " ") (conc " (" loc ") "))) "")))
      (cond  [(not arg) (error loc-str msg)]
	     [(token? arg)
	      (error (conc "line " (token-line arg) ": " msg) loc-str
		     (conc (token-symbol arg) 
			   (if (token-value arg) (conc " " (token-value arg)) "")))]
	     [else (error loc-str (conc msg arg))]
	     ))))

(define lexer-error error)

(define-record-type line
  (make-line indent content)
  line?
  (indent line-indent)
  (content line-content))

(define-record-printer (line x out)
  (fprintf out "#(line  ~S ~S)"
	   (line-indent x)
	   (line-content x) ))

(include "iexpr.l.scm")
(include "iexpr.grm.scm")

(define-datatype tree tree?
  (Empty)
  (Tree  (level integer?) (text identity) (sibling tree?) (child tree?)))

(define (tree-empty? t)
  (cases tree t 
	 (Tree (_ _ _ _) #f)
	 (Empty () #t)))

(define (tree-level t)
  (cases tree t
	 (Tree (l _ _ child) l)
	 (Empty () (error 'tree-level "tree is empty"))))

(define (tree-child t)
  (cases tree t
	 (Tree (_ _ _ child) child)
	 (Empty () (error 'tree-child "tree is empty"))))

(define (tree-sibling t)
  (cases tree t
	 (Tree (_ _ sib _) sib)
	 (Empty () (error 'tree-sibling "tree is empty"))))

(define (tree-update-child t child)
  (cases tree t
	 (Tree (l text sib _) (Tree l text sib child))
	 (Empty () (error 'tree-update-child "tree is empty"))))
  

(define (tree-update-sibling t sib)
  (cases tree t
	 (Tree (l text _ child) (Tree l text sib child))
	 (Empty () (error 'tree-update-sibling "tree is empty"))))
  

(define-datatype zipper zipper?
  (End) 
  (Zip  (level integer?) (tree tree?) (parent zipper?))
  )

(define (zip-level z)
  (cases zipper z
	(Zip (l _ _ ) l)
	(End () (error 'zip-level "already at end"))))

(define (zip-parent z)
  (cases zipper z
	(Zip (_ _ p) p)
	(End () (error 'zip-parent "already at end"))))

(define (zip-tree z)
  (cases zipper z
	(Zip (_ t _) t)
	(End () (error 'zip-tree "already at end"))))


(define (zip-end? z)
  (cases zipper z
	(Zip (_ _ _) #f)
	(End () #t)))



(define (zip-to-root z)
  (cases zipper z

	 (Zip (l t p) 
	      (cases zipper p
		     (End () z)
		     (Zip (_ t1 _)
			  (let* ((z (zip-update-tree p (tree-update-child t1 t)))
				 (zp (zip-parent z)))
			    (if (zip-end? zp) z zp)))
		     ))

	(End () (error 'zip-to-root "already at end"))))


(define (zip-update-tree z t)
  (cases zipper z
	 (Zip (l _ p) 
	      (cases zipper p
		     (End () (Zip l t p))
		     (Zip (_ t1 _)
			  (Zip l t (zip-update-tree p (tree-update-child t1 t))))
		     ))
	(End () z)))


(define (zip-up z)
  (cases zipper z
	 (Zip (_ t p) 
	      (cases zipper p
		     (End () z)
		     (Zip (l t1 p)
			  (Zip l (tree-update-child t1 t) p))
		     ))
	(End () (error 'zip-up "already at end"))))


(define (zip-insert-sibling z level text)
  (cases zipper z

	(Zip (l t parent) 
	      (if (= l level)
		  (let ((t1 (Tree level text t (Empty))))
		    (Zip l t1 parent))
		  (else (error 'zip-insert-sibling "new sibling must have level " l))))

	(End () (error 'zip-insert-sibling "already at end"))))


(define (zip-insert-child z level text)
  (cases zipper z

	 (Zip (zl zt zparent) 
	      (cases tree zt 
		     (Empty ()  (let* ((child (Tree level text (Empty) (Empty)))
				       (t (Tree 0 '(toplevel) (Empty) child)))
				  (Zip level child (Zip zl t zparent))))
		     (Tree (_ ztext zsib child)
			   (if (< zl level)
			       (let* ((child1 (Tree level text child (Empty)))
				      (t1     (Tree zl ztext zsib child1)))
				 (Zip level child1 z))
			       (else (error 'zip-insert-child "new sibling must have level greater than " zl))))
		     ))
	(End () (error 'zip-insert-child "already at end"))))

(define (initial-line-tree line) 
  (let ((n (line-indent line))
	(text (line-content line)))
    (Zip n (Tree n text (Empty) (Empty)) (End))))

(define (final-line-tree z) (zip-tree (zip-to-root z)))
      
(define (tree-insert-line line z)
  (cond ((< (line-indent line) (zip-level z))
	 (tree-insert-line line (zip-up z)))
	((= (line-indent line) (zip-level z))
	 (zip-insert-sibling z (line-indent line) (line-content line)))
	((> (line-indent line) (zip-level z))
	 (zip-insert-child z (line-indent line) (line-content line)))
	))
      
(define (tree->list t)
  (let recur ((t t) (ax '()))
    (cases tree t
	   (Tree (l t s c) 
		 (let ((n (if (tree-empty? c) t (append t (tree->list c)))))
		  (recur s (cons n ax))))
	   (Empty () ax))))

(define (parse loc s)
  (cond ((port? s)   (lexer-init 'port s))
	((string? s) (lexer-init 'string s))
	(else (error 'parse "bad argument type; not a string or port" s)) )
  (parser lexer (make-parse-error loc)))

)