module Vals where

import Control.Monad.Error
import Text.ParserCombinators.Parsec hiding (spaces)
import Text.ParseErrorEq ()
import Data.IORef
import System.IO

data LispVal = Atom Char | List [LispVal] | DottedList [LispVal] LispVal |
               Number Integer | String String | Bool Bool |
	             PrimitiveFunc Char |
	             Func { params :: [Char], vararg :: (Maybe Char),
         	            body :: [LispVal], closure :: Env } |
               IOFunc Char |
               Port Handle deriving Eq

unwordsList :: [LispVal] -> String
unwordsList = unwords . map showVal

valToChar :: LispVal -> Char
valToChar (Atom name) = name

valsToChars :: [LispVal] -> [Char]
valsToChars vals = map valToChar vals

showVal :: LispVal -> String
showVal (String str) = "\"" ++ str ++ "\""
showVal (Atom name) = show name
showVal (Number i) = show i
showVal (Bool True) = "#"
showVal (Bool False) = "~"
showVal (List contents) = "(" ++ unwordsList contents ++ ")"
showVal (DottedList hd tl) = "(" ++ unwordsList hd ++ " . " ++ showVal tl ++ ")"
showVal (PrimitiveFunc name) = "<primitive" ++ show name ++ ">"
showVal (Func {params = args, vararg = varargs, body = _, closure = _}) =
   "(\\ (" ++ unwords (map show args) ++
      (case varargs of
         Nothing -> ""
         Just arg -> " . " ++ show arg) ++ ") ...)"
showVal (Port h)   = "<IO port" ++ show h ++ ">"
showVal (IOFunc name) = "<IO primitive" ++ show name ++ ">"

instance Show LispVal where show = showVal

data LispError = NumArgs Integer [LispVal]
               | TypeMismatch String LispVal
               | Parser ParseError
               | BadSpecialForm String LispVal
               | NotFunction String String
               | UnboundVar String String
               | Default String deriving Eq

showError :: LispError -> String
showError (UnboundVar message varname)  = message ++ ": " ++ varname
showError (BadSpecialForm message form) = message ++ ": " ++ show form
showError (NotFunction message func)    = message ++ ": " ++ show func
showError (NumArgs expected found)      = "Expected " ++ show expected
                                       ++ " args; found values " ++ unwordsList found
showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected
                                       ++ ", found " ++ show found
showError (Parser parseErr)             = "Parse error at " ++ show parseErr

instance Show LispError where show = showError

instance Error LispError where
     noMsg = Default "An error has occurred"
     strMsg = Default

type ThrowsError = Either LispError

trapError :: (Show e, MonadError e m) => m String -> m String
trapError action = catchError action (return . show)

extractValue :: ThrowsError a -> a
extractValue (Right val) = val

type Env = IORef [(Char, IORef LispVal)]

type IOThrowsError = ErrorT LispError IO

liftThrows :: ThrowsError a -> IOThrowsError a
liftThrows (Left err) = throwError err
liftThrows (Right val) = return val

runIOThrows :: IOThrowsError String -> IO String
runIOThrows action = runErrorT (trapError action) >>= return . extractValue

isBound :: Env -> Char -> IO Bool
isBound envRef var = readIORef envRef >>= return . maybe False (const True) . lookup var

getVar :: Env -> Char -> IOThrowsError LispVal
getVar envRef var = do
	env <- liftIO $ readIORef envRef
	maybe	(throwError $ UnboundVar "Unbound variable" $ show var)
		(liftIO . readIORef)
		(lookup var env)

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

defineVar :: Env -> Char -> LispVal -> IOThrowsError LispVal
defineVar envRef var value = do
     alreadyDefined <- liftIO $ isBound envRef var
     if alreadyDefined
        then setVar envRef var value >> return value
        else liftIO $ do
             valueRef <- newIORef value
             env <- readIORef envRef
             writeIORef envRef ((var, valueRef) : env)
             return value

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