Index: /hh2008/naoya_t/20080301_GOODDAY/test.hs
===================================================================
--- /hh2008/naoya_t/20080301_GOODDAY/test.hs (revision 18)
+++ /hh2008/naoya_t/20080301_GOODDAY/test.hs (revision 18)
@@ -0,0 +1,17 @@
+main = putStrLn "Hello, World!"
+
+-- main = do { cs <- getContents ; print $ length $ lines cs }
+
+firstNLines n cs = unlines $ take n $ lines cs
+
+-- main = print $ 5 + 2 * 5
+rmain = print $ tail [1,2,3]
+-- main = tail [1,2,3]
+
+tail [1,2,3]
+print [1,2,3,4]
+
+fib 0 = 0
+fib 1 = 1
+fib n = fib (n-1) + fib (n-2)
+
Index: /hh2008/naoya_t/20080301_GOODDAY/test.sh
===================================================================
--- /hh2008/naoya_t/20080301_GOODDAY/test.sh (revision 18)
+++ /hh2008/naoya_t/20080301_GOODDAY/test.sh (revision 18)
@@ -0,0 +1,3 @@
+#!/bin/sh
+sed '/^$/d; /^--/d' test.hs | gosh -I. ihci.scm
+
Index: /hh2008/naoya_t/20080301_GOODDAY/peg.scm
===================================================================
--- /hh2008/naoya_t/20080301_GOODDAY/peg.scm (revision 18)
+++ /hh2008/naoya_t/20080301_GOODDAY/peg.scm (revision 18)
@@ -0,0 +1,509 @@
+;;;
+;;; peg.scm - Parser Expression Grammar Parser
+;;;
+;;;   Copyright (c) 2006 Rui Ueyama (rui314@gmail.com)
+;;;
+;;;   Redistribution and use in source and binary forms, with or without
+;;;   modification, are permitted provided that the following conditions
+;;;   are met:
+;;;
+;;;   1. Redistributions of source code must retain the above copyright
+;;;      notice, this list of conditions and the following disclaimer.
+;;;
+;;;   2. Redistributions in binary form must reproduce the above copyright
+;;;      notice, this list of conditions and the following disclaimer in the
+;;;      documentation and/or other materials provided with the distribution.
+;;;
+;;;   3. Neither the name of the authors nor the names of its contributors
+;;;      may be used to endorse or promote products derived from this
+;;;      software without specific prior written permission.
+;;;
+;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
+;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;
+
+(define-module peg
+  (use srfi-1)
+  (use srfi-13)
+  (use srfi-14)
+  (use util.match)
+  (export parse-success? parse-failure?
+          stream-position
+          <parse-error>
+
+          result-value
+          result-next
+          failure-type
+          failure-message
+          failure-position
+          parse-string
+          $return $fail $expect 
+          $do $cut $seq $or $many $skip-many
+          $repeat $optional
+
+          $alternate
+
+          $sep-by $end-by $sep-end-by
+          $count $between
+          $not $many-till $chain-left $chain-right
+          $lazy
+          $string $string-ci
+          $char $one-of $none-of
+          $satisfy
+
+          anychar upper lower letter alphanum digit
+          hexdigit newline tab space spaces eof
+
+          $->rope semantic-value-finalize!
+          )
+  )
+(select-module peg)
+
+(debug-print-width 1024)
+
+;;;============================================================
+;;; How is EBNF represented in the PEG library?
+;;;
+;;;   A ::= B C
+;;;     => (define a ($seq b c))
+;;;    If you need values of B and C, $do can be used:
+;;;     => (define a ($do ((x b) (y c)) (cons x y)))
+;;;
+;;;   A :: B | C
+;;;     => (define a ($or b c))
+;;;
+;;;   A :: B*
+;;;     => (define a ($many b))
+;;;
+;;;   A :: B+
+;;;     => (define a ($many b 1))
+;;;
+;;;   A ::= B B | B B B
+;;;     => (define a ($many b 2 3))
+;;;
+;;;   A ::= B?
+;;;     => (define a ($optional b))
+;;;
+
+;;;============================================================
+;;; Parse result types
+;;;
+
+;; result ::= ('success <semantic-value> <stream>)
+;; error ::= ('fail <failure-type> <message-string> <position>)
+
+(define-condition-type <parse-error> <error> #f
+  (position))
+
+(define-method write-object ((o <parse-error>) out)
+  (format out "#<<parse-error> ~a ~S>"
+          (ref o 'position)
+          (ref o 'message)))
+
+(define (parse-success? obj)
+  (and (vector? obj)
+       (eq? 'success (vector-ref obj 0))))
+
+(define (parse-failure? obj)
+  (and (vector? obj)
+       (eq? 'fail (vector-ref obj 0))))
+
+(define (make-result value stream)
+  (vector 'success value stream))
+
+(define result-value     (cut vector-ref <> 1))
+(define result-next      (cut vector-ref <> 2))
+(define failure-type     (cut vector-ref <> 1))
+(define failure-message  (cut vector-ref <> 2))
+(define failure-position (cut vector-ref <> 3))
+
+(define (make-message-failure m p)
+  (vector 'fail 'message (list m) p))
+(define (make-expect-failure m p)
+  (vector 'fail 'expect (list m) p))
+(define (make-unexpect-failure m p)
+  (vector 'fail 'unexpect (list m) p))
+
+;; entry point
+(define (parse-string parse str)
+  (define (error->string err)
+    (case (failure-type err)
+      ((message)  (failure-message err))
+      ((expect)   (failure-message err))
+      ((unexpect) (format #f "unexpected: ~a" (failure-message err)))))
+  (let1 r (parse (make-string-stream str))
+    (if (parse-success? r)
+      (semantic-value-finalize! (result-value r))
+      (raise (make-condition <parse-error>
+               'position (failure-position r)
+               'message (error->string r))))))
+
+;;;============================================================
+;;; Lazily-constructed string
+;;;
+(define-class <rope> ()
+  ((tree :init-keyword :tree)))
+
+(define (rope->string obj)
+  (define (traverse obj)
+    (cond ((is-a? obj <rope>)
+           (traverse (slot-ref obj 'tree)))
+          ((list? obj) (map traverse obj))
+          ((string? obj) (display obj))
+          ((char? obj) (display obj))
+          (else (error "don't know how to write:" obj))))
+  (with-output-to-string
+   (lambda () (traverse obj))))
+
+(define (make-rope obj)
+  (make <rope> :tree obj))
+
+;;;============================================================
+;;; Input Stream
+;;;
+
+;;(define (make-string-stream str)
+;;  (let loop ((str str) (pos 0))
+;;    (lambda ()
+;;      (if (zero? (string-length str))
+;;        (let loop () (values #f pos loop))
+;;        (values (string-ref str 0)
+;;                pos
+;;                (loop (string-drop str 1) (+ pos 1)))))))
+
+(define (make-string-stream str)
+  (let loop ((ptr (make-string-pointer str)))
+    (lambda ()
+      (let ((c (string-pointer-ref ptr))
+            (pos (string-pointer-index ptr)))
+        (if (eof-object? c)
+          (let loop () (values #f pos loop))
+          (let1 new-ptr (string-pointer-copy ptr)
+            (string-pointer-next! new-ptr)
+            (values c pos (loop new-ptr))))))))
+
+(define (stream-position s)
+  (values-ref (s) 1))
+
+;;;============================================================
+;;; Primitives
+;;;
+(define ($return val)
+  (lambda (s) (make-result val s)))
+
+(define ($fail msg)
+  (lambda (s)
+    (make-message-failure msg (stream-position s))))
+
+(define ($expect parse msg)
+  (lambda (s)
+    (let1 r (parse s)
+      (if (parse-success? r)
+        r
+        (make-expect-failure msg (stream-position s))))))
+
+(define ($unexpect msg pos)
+  (lambda (s)
+    (make-unexpect-failure msg pos)))
+
+;;;============================================================
+;;; Error handler
+;;;
+(define (merge-failure err)
+  (let loop ((r '()) (err err) (pos 0))
+    (if (null? err)
+      (vector 'fail
+              (vector-ref (car r) 1)
+              (append-map (cut vector-ref <> 2) (reverse! r))
+              pos)
+      (let1 npos (failure-position (car err))
+        (cond ((= pos npos)
+               (loop (cons (car err) r) (cdr err) pos))
+              ((< pos npos)
+               (loop (list (car err)) (cdr err) npos))
+              (else (loop r (cdr err) pos)))))))
+
+
+;;;============================================================
+;;; Backtrack control
+;;;
+(define-syntax $cut
+  (syntax-rules ()
+    ((_ mark) (set! mark #t))))
+
+;;;==================================================================
+;;; Combinators
+;;;
+(define-syntax $do
+  (syntax-rules ()
+    (($do :: var clause ...)
+     (begin ($cut var) ($do clause ...)))
+    (($do ((parse))) parse)
+    (($do parse) parse)
+    (($do (var parse) clause ...)
+     (lambda (s)
+       (let1 tmp (parse s)
+         (if (parse-success? tmp)
+           (let1 var (result-value tmp)
+             (($do clause ...) (result-next tmp)))
+           tmp))))
+    (($do ((parse)) clause ...)
+     (lambda (s)
+       (let1 tmp (parse s)
+         (if (parse-success? tmp)
+           (($do clause ...) (result-next tmp))
+           tmp))))
+    (($do c0 c1 c2 ...)
+     ($do (c0) c1 c2 ...))
+    (($do . rest)
+     (syntax-error "malformed $do binding form:" rest))))
+
+(define-syntax $or
+  (syntax-rules (quote)
+    (($or 'mark) ($return #t))
+    (($or 'mark p0 p1 ...)
+     (lambda (s)
+       (let1 mark #f
+         (let loop ((errors '())
+                    (parsers (list p0 p1 ...)))
+           (let1 r ((car parsers) s)
+             (cond ((parse-success? r) r)
+                   ((or mark (null? (cdr parsers)))
+                    (if (null? errors)
+                      r
+                      (merge-failure (reverse! (cons r errors)))))
+                   (else
+                    (loop (cons r errors) (cdr parsers)))))))))
+    (($or) ($return #t))
+    (($or p0) p0)
+    (($or p0 p1 ...)
+     (lambda (s)
+       (let loop ((errors '())
+                  (parsers (list p0 p1 ...)))
+         (let1 r ((car parsers) s)
+           (cond ((parse-success? r) r)
+                 ((null? (cdr parsers))
+                  (if (null? errors)
+                    r
+                    (merge-failure (reverse! (cons r errors)))))
+                 (else
+                  (loop (cons r errors) (cdr parsers))))))))))
+
+(define ($seq . parsers)
+  (match parsers
+    (() ($return #t))
+    ((parse) parse)
+    ((parse . rest)
+     ($do ((parse)) (apply $seq rest)))
+    (_ (error "can't be here"))))
+
+(define (%check-min-max min max)
+  (when (or (negative? min)
+            (and max (> min max)))
+    (error "invalid argument:" min max)))
+
+(define ($many parse . args)
+  (let-optionals* args ((min 0) (max #f))
+    (%check-min-max min max)
+    (lambda (s)
+      (define (max? count)
+        (and max (>= count max)))
+      (let loop ((r '()) (s s) (count 0))
+        (if (max? count)
+          (make-result (reverse! r) s)
+          (let1 v (parse s)
+            (cond ((parse-success? v)
+                   (loop (cons (result-value v) r)
+                         (result-next v)
+                         (+ count 1)))
+                  ((<= min count)
+                   (make-result (reverse! r) s))
+                  (else v))))))))
+
+(define ($skip-many . args)
+  (apply $many args))
+
+(define ($repeat parse n)
+  ($many parse n n))
+
+(define ($optional parse)
+  ($or parse ($return #f)))
+
+(define ($sep-by parse sep . args)
+  (let-optionals* args ((min 0) (max #f))
+    (%check-min-max min max)
+    (if (and max (zero? max))
+      ($return #t)
+      (lambda (s)
+        (let1 r (parse s)
+          (cond ((parse-success? r)
+                 (let1 r2 (($many ($do sep parse)
+                                  (clamp (- min 1) 0)
+                                  (and max (- max 1)))
+                           (result-next r))
+                   (if (parse-success? r2)
+                     (make-result (cons (result-value r) (result-value r2))
+                                  (result-next r2))
+                     r2)))
+                ((zero? min) (make-result #t s))
+                (else r)))))))
+
+(define ($alternate parse sep)
+  ($do (h parse)
+       (t ($many ($do (v1 sep) (v2 parse) ($return (list v1 v2)))))
+       ($return (cons h (apply append! t)))))
+
+(define ($end-by parse sep . args)
+  (apply $many ($do (v parse) sep ($return v)) args))
+
+(define ($sep-end-by parse sep . args)
+  ($do (v (apply $sep-by parse sep args))
+       (($optional sep))
+       ($return v)))
+
+(define ($count parse n)
+  ($many parse n n))
+
+(define ($between open parse close)
+  ($do open (v parse) close ($return v)))
+
+(define ($not parse)
+  (lambda (s)
+    (($or 'grp
+          ($do (v parse) :: grp ($unexpect v (stream-position s)))
+          ($return #f))
+     s)))
+
+(define ($many-till parse end . args)
+  (apply $many ($do (($not end)) parse) args))
+
+(define ($chain-left parse op)
+  (lambda (st)
+    (let1 r (parse st)
+      (if (parse-success? r)
+        (let loop ((r r))
+          (let1 r2 (($do (proc op) (v parse)
+                         ($return (proc (result-value r) v)))
+                    (result-next r))
+            (if (parse-success? r2)
+              (loop r2)
+              r)))
+        r))))
+
+(define ($chain-right parse op)
+  (rec (loop st)
+    (($do (h parse)
+          ($or ($do (proc op)
+                    (t loop)
+                    ($return (proc h t)))
+               ($return h)))
+     st)))
+
+(define-syntax $lazy
+  (syntax-rules ()
+    ((_ parse)
+     (lambda args (apply parse args)))))
+
+;;;============================================================
+;;; Intermediate structure constructor
+;;;
+(define ($->rope parse)
+  ($do (v parse) ($return (make-rope v))))
+
+(define (semantic-value-finalize! obj)
+  (cond ((is-a? obj <rope>) (rope->string obj))
+        ((pair? obj)
+         (cons (semantic-value-finalize! (car obj))
+               (semantic-value-finalize! (cdr obj))))
+        (else obj)))
+
+;;;============================================================
+;;; String parsers
+;;;
+(define ($satisfy pred expect)
+  (lambda (s)
+    (receive (c pos next) (s)
+      (if c
+        (let1 r (pred c)
+          (if r
+            (make-result c next)
+            (make-expect-failure expect pos)))
+        (make-expect-failure expect pos)))))
+
+(define-values ($string $string-ci)
+  (let-syntax
+      ((expand
+        (syntax-rules ()
+          ((_ char=)
+           (lambda (str)
+             (let1 lis (string->list str)
+               (lambda (s)
+                 (let loop ((r '()) (s s) (lis lis))
+                   (if (null? lis)
+                     (make-result (make-rope (reverse! r)) s)
+                     (receive (c pos next) (s)
+                       (if (and c (char= c (car lis)))
+                         (loop (cons c r) next (cdr lis))
+                         (make-expect-failure str (stream-position s)))))))))))))
+    (values (expand char=?)
+            (expand char-ci=?))))
+
+(define ($char c)
+  ($satisfy (cut char=? c <>) c))
+
+(define ($char-ci c)
+  ($satisfy (cut char-ci=? c <>)
+            (list->char-set c (char-upcase c) (char-downcase c))))
+
+(define ($one-of charset)
+  ($satisfy (cut char-set-contains? charset <>)
+            charset))
+
+(define ($none-of charset)
+  ($one-of (char-set-complement charset)))
+
+(define (anychar st)
+  (receive (c pos next) (st)
+    (if c
+      (make-result c next)
+      (make-expect-failure "character" pos))))
+
+(define-syntax define-char-parser
+  (syntax-rules ()
+    ((_ proc charset expect)
+     (define proc
+       ($expect ($one-of charset) expect)))))
+
+(define-char-parser upper    #[A-Z]         "upper case letter")
+(define-char-parser lower    #[a-z]         "lower case letter")
+(define-char-parser letter   #[A-Za-z]      "letter")
+(define-char-parser alphanum #[A-Za-z0-9]   "letter or digit")
+(define-char-parser digit    #[0-9]         "digit")
+(define-char-parser hexdigit #[0-9A-Fa-f]   "hexadecimal digit")
+(define-char-parser newline  #[\n]          "newline")
+(define-char-parser tab      #[\t]          "tab")
+(define-char-parser space    #[ \v\f\t\r\n] "space")
+
+(define spaces ($->rope ($many space)))
+
+(define eof
+  (lambda (s)
+    (receive (c pos next) (s)
+      (if c
+        (make-expect-failure "end of input" pos)
+        (make-result #t next)))))
+
+;;============================================================
+;; Token Parsers
+;;
+
+(provide "peg")
Index: /hh2008/naoya_t/20080301_GOODDAY/ihci.scm
===================================================================
--- /hh2008/naoya_t/20080301_GOODDAY/ihci.scm (revision 18)
+++ /hh2008/naoya_t/20080301_GOODDAY/ihci.scm (revision 18)
@@ -0,0 +1,289 @@
+(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))))]
+		 )
+	($between %dquote %string-body %dquote)))
+
+(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 (string->symbol (list->string (cons head rest)))))))
+
+(define %digits
+  ($do (d ($many digit 1))
+	   ($return (tag :number (string->number (list->string d))))))
+
+(define %list
+  (let* ([%begin-list ($seq %ws ($char #\[) %ws)]
+		 [%end-list ($seq %ws ($char #\]) %ws)]
+		 [%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 ($seq %ws ($char #\() %ws)]
+		 [%end-list ($seq %ws ($char #\)) %ws)]
+		 [%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 %expr
+  ($or %string %digits %ident %list %tuple))
+
+(define %application
+  (let1 %an-application
+	  ($do (fn %ident)
+		   %ws
+		   (args ($my-sep-by %expr %ws))
+		   ($return `(:apply ,fn ,@args)))
+	($do (app1 %an-application)
+		 (apps ($many ($do %ws
+						   (($char #\$))
+						   %ws
+						   (app %an-application)
+						   ($return app))))
+		 ($return (if (= 0 (length apps)) app1 `(:$ ,app1 ,@apps))))))
+
+(define %haskell
+  (let* ([%unknown ($my-sep-by %expr %ws)]
+		 
+		 [%assignment ($do (id %ident)
+						   %ws
+						   (($string "<-"))
+						   %ws
+						   (value %application)
+						   ($return `(:assign ,id ,value))
+						   )]
+		 [%do-line-separator ($seq %ws ($or ($seq newline ($string "  ")) ($char #\;)) %ws)]
+		 [%do ($do (($string "do"))
+				   %ws
+				   (exprs ($or ($between ($seq ($char #\{) %ws)
+										 ($my-sep-by ($or %assignment %application)
+													 ($seq %ws ($char #\;) ($optional ($seq newline ($string "  "))) %ws))
+										 ($seq %ws ($char #\})))
+							   ($my-sep-by ($or %assignment %application)
+										   ($seq newline ($string "  ") %ws)) ))
+				   ($return `(:do ,@exprs)))]
+
+		 [%defun ($do (id %ident)
+					  %ws
+					  (args ($my-sep-by %ident %ws))
+					  %ws
+					  (($char #\=))
+					  %ws
+					  (rightside ($or %do %application))
+					  ($return `(:defun (,id ,@args) ,rightside))
+					  )]
+		 [%pattern ($do (id %ident)
+						%ws
+						(args ($my-sep-by ($or %ident %digits) %ws))
+						%ws
+						(($char #\=))
+						%ws
+						(rightside ($or %do %application))
+						($return `(:pattern (,id ,@args) ,rightside))
+						)]
+
+		 )
+	($or %defun %pattern %assignment %application %expr
+		 %unknown)
+	))
+
+(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 (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)
+  (let1 val (hash-table-get *namespace* id)
+	;
+	val))
+
+;;
+(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)
+  (if (or (null? exp) (not (pair? exp))) *undefined*
+	  (match exp
+		[(':$ . _)
+;		 (delay-it
+		  (let loop ([rest (cdr exp)])
+			(if (null? (cdr rest))
+				(heval (car rest) env)
+				(heval (append (car rest) (list (loop (cdr rest)))) env)
+				))
+;		  env)
+		  ]
+		[(':apply f . _)
+		 (if (null? (cddr exp))
+;			 (delay-it (list (ident-body f)) env)
+			 (list (ident-body f))
+			 `(,(ident-body f) ,@(cddr exp)); ,@(map (cut heval <> env) (cdr exp)))
+;			 (delay-it `(,(ident-body f)
+;						 ,@(map (cut heval <> env) (cdr exp)))
+;					   env)
+			 )]
+		[(':assign x y) ; id <- action
+		 (assign (ident-body x) (heval y env))]
+		[(':do . _) ; do { ... ; ... ; ... }
+		 `(seq ,@(heval-map (cdr exp) 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)) )
+								   env)))]
+		[(':pattern 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)) )
+								   env)))]
+		
+		[(':string . str) str]
+		[(':list . l) l]
+		[(':tuple . t) t]
+		[(':ident . id) id]
+
+		[_ (if (pair? 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)]
+		  [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*)))
+	  )))
+
+(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))
+
+(define (make-frame vars vals) (cons vars vals))
+
+(define (extend-environment vars vals base-env)
+  ;; assert-equal (length vars) (length vals)
+  (cons (make-frame vars vals) base-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-map (procedure-body proc) env))]
+		[else
+		 ;
+		 ]))
+
+;; REPL
+(let repl ()
+  (let1 input (read-line)
+	(if (eof-object? input) 'eof
+		(let1 parsed (parse-haskell input); (haskell->scheme input)
+		  (let1 evaled (heval parsed '())
+			(print "> " input)
+			(print "=> " parsed)
+			(print "" evaled))
+		  (repl)))))
+
+(define (actual-value exp); env)
+  (force-it (heval exp '())))
+
+(let1 main (lookup 'main)
+  (print "----")
+   (happly main '())
+   )