(defmodule Scheme _ (Data.IORef System.IO Data.List Data.Maybe))

(defenv (lambda ((LskEnv e p t d)) 
	  (return (LskEnv (dspr-namespace-dspr e) p t (define-dspr-dspr d)))))
(defenv (lambda ((LskEnv e p t d)) 
	  (return (LskEnv e p t (d(add-dspr) d)))))

(add-dspr (expression simple-list)
	  (expression cond)
	  (expression sParseTree-e)
	  (expression ++*)
	  (pattern :*)
	  (pattern simple-list)
	  (pattern sParseTree-p)
	  (expression backquote)
	  (declaration def-hdsprs)
	  (declaration defmacros)
	  (declaration defdata-deriving)
	  (declaration derive-eq)
	  (declaration derive-show))

(defdata SData
  (SBool Bool)
  (SNum Integer)
  (SChar Char)
  (SVec ([] (IORef SData)))
  (SCons (IORef SData) (IORef SData))
  (SString String)
  (SPort Handle)
  (SFun (-> ([] SData) (SchemeMonad SData))))

(definstance (Show SData)
    ((show (SNum i)) (++* "(SNum "
			  (show i)
			  ")")))

(define (boolify sdata)
    (case sdata
      ((SBool bool)
       bool)
      ((SNum int)
       (not (== int 0)))
      ((SChar _)
       True)))

(deftype Id String)

(deftype GlobalVarbinds ([] (, Id (IORef SData))))

(defdata (SchemeMonad a)
    (SM (-> GlobalVarbinds (-> a (IO SData)) (IO SData))))

(define (runSM (SM a))
    a)

(definstance (Monad SchemeMonad)
    ((return a) (SM (lambda (gv k)
		      (k a))))
  ((>>= (SM f) b)
   (SM (lambda (gv k)
	 (f gv
	    (lambda (v)
	      (runSM (b v) gv k)))))))

(define sm-get-global-vars
    (SM (lambda (gv k)
	  (k gv))))

(define (sm-trf-global-vars tf (SM sf))
    (SM (lambda (gv k)
	  (sf (tf gv) k))))

(define (sm-var-ioref var-string)
    (>>= sm-get-global-vars
	 (lambda (gv-lst)
	   (return (fromMaybe (error "Variable not found in lexical scope")
			      (>>= (find (. (== var-string) fst) gv-lst)
				   (. return snd)))))))

(define (sm-liftIO iom)
    (SM (lambda (gv k)
	  (>>= iom
	       (lambda (a)
		 (k a))))))

(define (sm-read-var id)
    (>>= (sm-var-ioref id)
	 (lambda (ioref)
	   (sm-liftIO (readIORef ioref)))))

(define (sm-write-var id value)
    (>>= (sm-var-ioref id)
	 (lambda (ioref)
	   (sm-liftIO (writeIORef ioref value)))))

(define (sm-new-var id value)
    (>>= (sm-liftIO (newIORef value))
	 (lambda (ioref)
	   (return (, id ioref)))))

(define (trfs-expr pt)
    (case pt
      ((SList ([] (SSym "set!")
		  (SSym sym)
		  r))
       `(>>= ,(trfs-expr r)
	     (lambda (val)
	       (sm-write-var ,(SString sym) val))))
      ((SList ([] (SSym "if")
		  c
		  t
		  e))
       `(>>= ,(trfs-expr c)
	     (lambda (v)
	       (if (boolify v)
		   ,(trfs-expr t)
		   ,(trfs-expr e)))))
      ((SList (:* (SSym "lambda")
		  (SList lambda-args)
		  body))
       `(return (SFun (lambda (args)
			(if (== ,(length lambda-args)
				(length args))
			    (>>= (sequence (zipWith sm-new-var
						   ([] ,@(map (. (lambda (x)
								   (SString x))
								 pt_sym) lambda-args))
						   args))
				 (lambda (new-locals)
				   (sm-trf-global-vars (++ new-locals) ,(trfs-exprs body))))
			    (error "Invalid number of args for function call"))))))
      ((SList (: (SSym "begin")
		 rest))
       (trfs-exprs rest))
      ((SList (: fun
		 args))
       `(>>= ,(trfs-expr fun)
	     (lambda ((SFun fun))
	       (>>= (sequence ([] ,@(map trfs-expr args)))
		    (lambda (evaled-args)
		      (fun evaled-args))))))
      ((SSym v)
       (fromMaybe `(sm-read-var ,(SString v))
		  (>>= (convertNumber v)
		       (lambda (num)
			 (Just `(return (SNum ,(SSym (show num)))))))))))

(define (trfs-exprs pts)
    (case pts
      (([] single)
       (trfs-expr single))
      ((: one rest)
       `(>> ,(trfs-expr one)
	    ,(trfs-exprs rest)))))

(define (runScheme (SM f))
    (f ([]) return))

(define pt1 `((lambda (x) 1 (set! x 10) x) 2))