{- Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu>
Portions of this were derived from Jonathan Tang's haskell
tutorial "Write yourself a scheme in 48 hours" and are thus
Copyright Jonathan Tang (but there isn't much of his stuff left).

This file is part of haskeem.
haskeem 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 2 of the License, or
(at your option) any later version.

haskeem 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.

You should have received a copy of the GNU General Public License
along with haskeem; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

$Id: environment.hs,v 1.14 2010-01-05 05:23:34 uwe Exp $ -}

module Environment (isBound, getVar, setVar,
                    defineVar, bindVars, dumpEnv) where
import Prelude
import Data.Maybe
import IO
import Control.Monad.Error as CME
import Data.IORef

import LispData

liftRead :: MonadIO m => IORef a -> m a
liftRead = liftIO . readIORef

isBound :: Env -> String -> IO Bool
isBound envRef var =
  do env <- liftIO (readIORef envRef)
     return (isJust (lookup var env))

getVar :: Env -> String -> IOThrowsError LispVal
getVar envRef var =
  do env <- liftRead envRef
     maybe (throwError (UnboundVar "Getting an unbound variable" var))
           liftRead (lookup var env)

setVar :: Env -> String -> LispVal -> IOThrowsError LispVal
setVar envRef var value =
  do env <- liftRead envRef
     maybe (throwError (UnboundVar "Setting an unbound variable" var))
           (liftIO . flip writeIORef value)
           (lookup var env)
     return value

defineVar :: Env -> String -> LispVal -> IOThrowsError LispVal
defineVar envRef var value =
  liftIO (do valueRef <- newIORef value
             env <- readIORef envRef
             writeIORef envRef ((var, valueRef) : env)
             return value)

bindVars :: Env -> [(String, LispVal)] -> IO Env
bindVars envRef bindings =
  readIORef envRef >>= extendEnv >>= newIORef
  where extendEnv env = liftM (++ env) (mapM addBinding bindings)
        addBinding (var, value) = do ref <- newIORef value
                                     return (var, ref)

-- The lastkey argument is for internal debugging: pass a non-empty string
-- in, and the dump will stop before printing that symbol... useful for
-- shortening the output. Not currently accessible at the scheme level.

dumpEnv :: Env -> Handle -> String -> IOThrowsError LispVal
dumpEnv envRef port lastkey = liftRead envRef >>= doDump
  where doDump [] = return lispTrue
        doDump ((key, vref):vars) =
          if key == lastkey
             then return lispTrue
             else do val <- liftRead vref
                     liftIO (hPutStrLn port (key ++ " -> " ++ show val))
                     doDump vars