;;
;; IHC - Ikoma Haskell Compiler
;;
(use srfi-1)

(define *undefined* (if #f #f))

(define (tagged? tag obj) (and (pair? obj) (eq? (car obj) tag)))
(define (tagged?$ tag) (lambda (obj) (and (pair? obj) (eq? (car obj) tag))))
(define (tag t obj) (cons t obj))
(define (tag$ t) (lambda (obj) (cons t obj)))
(define (untag obj) (cdr obj))

(use peg)

(define (nil-if-true l) (if (eq? #t l) '() l))
(define ($my-sep-by parse sep . args)
  ($do (them ($sep-by parse sep))
	   ($return (nil-if-true them))))

(define %ws ($many ($one-of #[ \t\r\n])))

(define %string ; scheme-string で代用
  (let* ([%dquote ($char #\")]
         [%unescaped ($none-of #[\"])]
         [%body-char ($or %unescaped)]
         [%string-body ($do (chars ($many %body-char))
;							($return (tag :string (list->string chars))))]
							($return (list->string chars)))]
		 )
	($between %dquote %string-body %dquote)))

(define %char
  ($do (($char #\'))
	   (($optional ($char #\\)))
	   (ch anychar)
	   (($char #\'))
;	   ($return (tag :char ch))
	   ($return ch)
	   ))

(define %ident ;; scheme-symbolで代用
  (let* ([%ident-head-char ($one-of #[a-z_])]
		 [%ident-rest-char ($one-of #[0-9A-Za-z_'])])
	($do (head %ident-head-char)
		 (rest ($many %ident-rest-char))
;		 ($return (tag :ident (string->symbol (list->string (cons head rest))))))))
		 ($return (string->symbol (list->string (cons head rest)))))))

(define %digits
  ($do (d ($many digit 1))
;	   ($return (tag :number (string->number (list->string d))))))
	   ($return (string->number (list->string d)))))

(define %list
  (let* ([%begin-list ($char #\[)]
		 [%end-list ($char #\])]
		 [%item ($or %digits %string %ident)]
		 [%item-separator ($seq %ws ($char #\,) %ws)]
		 )
	($do %begin-list
		 (items ($my-sep-by %item %item-separator))
		 %end-list
		 ($return (tag :list items)))
	))

(define %tuple
  (let* ([%begin-list ($char #\()]
		 [%end-list ($char #\))]
		 [%item ($or %digits %string %ident)]
		 [%item-separator ($seq %ws ($char #\,) %ws)]
		 )
	($do %begin-list
		 (items ($my-sep-by %item %item-separator))
		 %end-list
		 ($return (tag :tuple @items)))
	))

(define %atomic
  ($or %string %char %digits %ident %list %tuple))

(define (char->symbol ch)
  (string->symbol (x->string ch)))

(define %infixed
  (let1 %infix ($or ($one-of #[-+*/<>])
					($string "==") ($string "<=") ($string ">="))
	($do (item1 %atomic);($or %application %atomic)) ;%atomic)
;		 (seq ($do %ws
;				   (infix %infix)
										;				   %ws
;				   (rest ($or %infixed %atomic))
;				   ($return (cons infix rest))))
		 %ws
		 (infix %infix)
		 %ws
		 (item2 %atomic);($or %application %atomic)) ;%atomic)
		 (rest ($many ($do %ws
						   (infix %infix)
						   %ws
						   (item %atomic);($or %application %atomic)) ;%atomic)
						   ($return (list (char->symbol infix) item)))))
		 ($return (let1 expr (append (list item1 (char->symbol infix) item2)
									 (apply append rest))
					(case (length expr)
					  ((3)
					   (list ':apply (second expr) (first expr) (third expr)))
					  ((5) ; 優先度まだ
					   (list ':apply (fourth expr)
							 (list ':apply (second expr) (first expr) (third expr))
							 (fifth expr)))
					  )))
					;(tag :infixed (append (list item1 (char->symbol infix) item2)
					;(apply append rest))))
		 )))
;		 (seq ($or ($do %ws
;						(infix %infix)
;						%ws
;						(rest %infixed)
;						($return (cons infix rest)))
;				   ($do %ws
;						(infix %infix)
;						%ws
;						(rest %atomic)
;						($return (list infix rest))) ))
;		 ($return (tag :infixed (cons elem1 seq))))))

(define %expr
  ($or %infixed 
;	   ($between ($char #\() %expr ($char #\)))
	   %if %atomic))

(define %comment
  ($or
   ($seq ($string "-- ") ($none-of #[\n]) ($char #\n))
   ($seq ($string "{-") ($many anychar) ($string "-}"))
   ))

(define %if
  ($do (($string "if"))
	   %ws
	   (cond %expr)
	   %ws
	   (($string "then"))
	   %ws
	   (conseq %expr)
	   (alt ($optional ($do %ws (($string "else")) %ws 
							(alt %expr)
							($return alt))))
	   ($return (tag :if (list cond conseq alt)))))

(define %application
  (let1 %an-application
	  ($do (fn %ident)
		   %ws
		   (arg1 ($or %expr
					  ($between ($char #\() %expr ($char #\)))))
		   %ws
		   (args ($my-sep-by %expr %ws))
		   ($return `(:apply ,fn ,arg1 ,@args)))
	($do (app1 ($or %infixed %an-application %lambda %ident))
		 (apps ($many ($do %ws
						   (($char #\$)) ; " $ "
						   %ws
						   (app ($or %infixed %an-application %lambda %ident))
						   ($return app))))
		 ($return (if (= 0 (length apps)) app1 `(:$ ,app1 ,@apps))))))

(define %lambda
  ($do (($char #\\))
	   (vars ($my-sep-by %ident %ws))
	   %ws
	   (($string "->"))
	   %ws
	   (body ($or %do %infixed %application %expr))
	   ($return (tag ':lambda (list vars body)))))

(define %assignment
  ($do (id %ident)
	   %ws
	   (($string "<-"))
	   %ws
	   (value ($or %infixed %application %expr))
	   ($return `(:assign ,id ,value))
	   ))

(define %do
  (let1 %do-line-separator ($seq %ws ($or ($seq newline ($string "  ")) ($char #\;)) %ws)
	($do (($string "do"))
		 %ws
		 (exprs ($or ($between ($seq ($char #\{) %ws)
							   ($my-sep-by ($or %assignment %infixed %application %expr)
										   ($seq %ws ($char #\;) ($optional ($seq newline ($string "  "))) %ws))
							   ($seq %ws ($char #\})))
					 ($my-sep-by ($or %assignment %infixed %application %expr)
								 ($seq newline ($string "  ") %ws)) ))
		 ($return `(:do ,@exprs)))))

(define %defun
  ($do (id %ident)
	   %ws
	   (args ($my-sep-by %ident %ws))
	   %ws
	   (($char #\=))
	   %ws
	   (rightside ($or %do %infixed %application %expr))
	   ($return `(:defun (,id ,@args) ,rightside))
	   ))

(define %pattern
  ($do (id %ident)
	   %ws
	   (args ($my-sep-by ($or %ident %digits) %ws))
	   %ws
	   (($char #\=))
	   %ws
	   (rightside ($or %do %infixed %application %expr))
	   ($return `(:pattern (,id ,@args) ,rightside))
	   ))

(define %haskell
  (let* ([%unknown ($my-sep-by %expr %ws)]
		 )
	($or %comment %lambda %defun %pattern %assignment %infixed %if %application %expr
		 %unknown
		 newline)
	))

(define (parse-haskell str)
  (parse-string %haskell str))
		  
(define putStrLn print)

(define ident? symbol?)
(define ident-body identity)
;(define ident? (tagged?$ :ident))
;(define ident-body untag)

(define lambda? (tagged?$ :lambda))

(define (indent w lines)
  (string-join (map (lambda (line) (string-append (make-string w #\space) (x->string line)))
					lines)
			   "\n"))

(define *namespace* (make-hash-table))
(define (assign id val)
  (hash-table-put! *namespace* id val)
  id)

(define (lookup id env)
  (let1 val (lookup-variable-value id env)
	(if val val (hash-table-get *namespace* id))))

;;
(define (make-procedure params body env)
  (list :procedure params body env))

(use util.match)
(define (heval-map exps env) (map (cut heval <> env) exps))
(define (heval exp env)
;  (print "HEVAL " exp)
  (cond [(null? exp) *undefined*]
		[(number? exp) exp]
		[(string? exp) exp]
		[(char? exp) exp]
		[(symbol? exp) (let1 val (lookup exp env)
						 (if val (heval val env) *undefined*))]
		[else (match exp
				[(':$ . _)
				 (let loop ([apps (map (lambda (e) (if (or (ident? e) (lambda? e))
													   (list ':apply e) e))
									   (cdr exp))])
				   (if (null? (cdr apps))
					   (heval (car apps) env)
					   (heval (append (car apps)
									  (list (loop (cdr apps))))
							  env)
					   ))
				 ]

				[(':apply f . _)
				 (let ([f (cadr exp)]
					   [args (cddr exp)])
				   (happly
					(if (symbol? f) f (heval (second exp) env))
					(heval-map args env))
				   )]

				[(':assign x y) ; id <- action
				 (assign (ident-body x) (heval y env))]

				[(':if cond then)
				 (if cond then *undefined*)]
				[(':if cond then else)
				 (if cond then else)]

				[(':do . _) ; do { ... ; ... ; ... }
				 `(seq ,@(heval-map (cdr exp) env))]

				[(':lambda args . lambda-body)
				 (make-procedure (map ident-body args) ;lambda-parameters
								 lambda-body
								 env)]

				[(':defun id definition) ; id x y z = app x $ app y $ app z
				 (let ([ident (car id)]
					   [args (cdr id)])
				   (assign (ident-body ident)
						   (make-procedure (map ident-body args) ;lambda-parameters
										   (if (eq? 'seq (car definition)) ; lambda-body
										;(heval definition env)
										;(list (heval definition env)) )
											   definition
											   (list definition))
										   env)))]

				[(':pattern id definition) ; id x y z = app x $ app y $ app z
				 (let ([ident (car id)]
					   [args (cdr id)])
				   )]
				
				[(':string . str) str]
				[(':list . l) l];(heval-map l env)]
				[(':tuple . t) t]
				[(':ident . id) id]

				[_ (if (pair? exp) exp ;(happly (car exp) (cdr exp))
					   (format "unknown: ~a" exp))]

				)]))

(define (primitive-procedure? proc)
  (memq proc '(putStr 
			   putStrLn
			   lines length print
			   tail
			   * + - /)))

(define (prim-print exp)
  (define (haskell-description-of-list l)
	(string-append "[" (string-join (map haskell-description l) ",") "]"))
	
  (define (haskell-description obj)
	(cond [(not (pair? obj)) (x->string obj)]
		  [(tagged? :number obj) (number->string (untag obj))]
		  [(tagged? :string obj) (untag obj)]
		  [(tagged? :list obj) ; (untag obj)]
		   (list->haskell-string (untag obj))]
		  [(pair? obj) (haskell-description-of-list obj)]
		  [(number? obj) (number->string obj)]
		  [(string? obj) obj]
		  [else (x->string obj)]))
  (print (haskell-description exp)))

(define (prim-tail exp)
  (cond [(tagged? :string exp) (substring (cdr exp) 1 (string-length (cdr exp)))]
		[(tagged? :list exp) (cddr exp)]
		[(pair? exp) (cdr exp)]
		[else *undefined*]))

(define (apply-primitive-procedure proc args)
  (let1 args* (heval-map args '())
	(case proc
	  [(putStr) (display (x->string (car args*)))]
	  [(putStrLn) (apply prim-print args*)]
	  [(print) (apply prim-print args*)]
	  [(lines) (length args*)]
	  [(length) (if (tagged? :string (car args*))
					(string-length (car args*))
					(length (car args*)))]
	  [(tail) (prim-tail (car args*))]

	  [(*) (apply * args*)]
	  [(+) (apply + args*)]
	  [(/) (apply / args*)]
	  [(-) (apply - args*)]
;	  [else (error "unknown primitive: " proc)]
	  )))

(define (compound-procedure? proc) (tagged? :procedure proc))

(define (procedure-parameters proc) (second proc))
(define (procedure-body proc) (third proc))
(define (procedure-environment proc) (fourth proc))

; SICP pp225-226
(define (enclosing-environment env) (cdr env))
(define (first-frame env) (car env))
(define the-empty-environment '())

(define (make-frame vars vals) (cons vars vals))
(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))

(define (extend-environment vars vals base-env)
  ;; assert-equal (length vars) (length vals)
  (cons (make-frame vars vals) base-env))

(define (lookup-variable-value var env)
  (define (env-loop env)
	(define (scan vars vals)
	  (cond [(null? vars)
			 (env-loop (enclosing-environment env))]
			[(eq? var (car vars))
			 (car vals)]
			[else (scan (cdr vars) (cdr vals))]))
	(if (eq? env the-empty-environment)
		#f ; (error "unbound variable" var)
		(let1 frame (first-frame env)
		  (scan (frame-variables frame)
				(frame-values frame)))))
  (env-loop env))

(define (last-exp? seq) (null? (cdr seq)))
(define (heval-sequence exps env)
  (cond [(last-exp? exps) (heval (car exps) env)]
		[else (heval (car exps) env)
			  (heval-sequence (cdr exps) env)]))

(define (happly proc args)
  (cond [(primitive-procedure? proc)
		 (apply-primitive-procedure proc args)]
		[(compound-procedure? proc)
		 (let1 env (extend-environment (procedure-parameters proc)
									   args
									   (procedure-environment proc))
		   (heval-sequence (procedure-body proc) env))]
		[else
		 ;
		 ]))

;; REPL
(let repl ()
  (let1 input (read-line)
	(if (eof-object? input) 'eof
		(begin
		  (when (and (string? input) (< 0 (string-length input)))
			(print "> " input)
			(let1 parsed (parse-haskell input); (haskell->scheme input)
			  (print "=> " parsed)
			  (let1 evaled (heval parsed '())
				(print "=> " evaled)
										;			  (if evaled (print ": " (heval evaled '())))
				))
			(print ""))
		  (repl)))))

;(define (actual-value exp); env)
;  (if (and (pair? exp) (tagged? ':apply exp))
;	  (
;  (force-it (heval exp '())))

(let1 main (lookup 'main '())
  (print "====")
  (happly main '())
  )