haskeem-0.7.4: Environment.hs

{- 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 I can't easily tell anymore who originally wrote what)

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.11 2009-06-27 20:31:51 uwe Exp $ -}

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

import LispData

liftRead = liftIO . readIORef

isBound :: Env -> String -> IO Bool
isBound envRef var =
  do env <- liftIO (readIORef envRef)
     return (maybe False (const True) (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)

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