;;
;;  A parser for I-expressions (based on SRFI-49)
;;
;; Copyright 2010-2012 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-syntax tok
  (syntax-rules ()
    ((tok line t) (make-lexical-token
		   (quasiquote t) 
		   (make-source-location #f line #f #f #f) #f))
    ((tok line t l) (make-lexical-token
		     (quasiquote t) 
		     (make-source-location #f line #f #f #f)
		     l))
    ))

(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.grm.scm")
(include "iexpr.l.scm")


(define (make-parse-error loc)
  (lambda (msg #!optional arg)
    (let ((loc-str (or (and loc (cond ((list? loc) (sprintf "~A" loc))
				      ((string? loc) (sprintf "(~A)" loc))
				      (else (sprintf "(~A)" loc))))
		       "")))
      (cond  [(not arg) (error loc-str msg)]
	     [(lexical-token? arg)
	      (error (sprintf "~A, line ~A" loc-str (source-location-line (lexical-token-source arg))) 
		     (sprintf "~A ~A~A" 
			      msg (lexical-token-category arg) 
			      (if (lexical-token-value arg) 
				  (sprintf " ~A" (lexical-token-value arg)) "")))]
	     [else (error loc-str (sprintf "~A ~A" msg arg))]
	     ))))

(define lexer-error error)

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

(define-record-printer (tree x out)
  (cases tree x
	 (Empty () 
		(fprintf out "#<Empty>"))
	 (Tree (l t s c)
	       (fprintf out "#<Tree ~A ~A ~A ~A>" l t s c))
	 ))
	       

(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 child1) 
	       (Tree l text sib (tree-add-sibling child1 child)))
	 (Empty () (error 'tree-update-child "tree is empty"))))
  

(define (tree-add-sibling t sib)
  (if (tree-empty? sib) t
      (cases tree t
	     (Tree (l text sib1 child) 
		   (cases tree sib
			  (Tree (sl stext _ schild)
				(Tree l text (Tree sl stext sib1 schild) child))
			  ))
	     (Empty () sib))))
  

(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) 
	      (if (zip-end? p) z
		  (zip-to-root (zip-up z))))
	(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 pt pp)
			  (Zip l (tree-update-child pt t) pp))
		     ))
	(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))))
				 (Zip level child1 z))
			       (else (error 'zip-insert-child "new child 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) (level 0) (ax '()))
    (cases tree t
	   (Tree (l tt s c) 
		 (let ((n (if (tree-empty? c) tt (append tt (tree->list c)))))
		   (recur s l (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)))

)