module Language.Scheme.Types where
import Data.Complex
import Control.Monad.Error
import Data.Array
import Data.IORef
import qualified Data.Map
import System.IO
import Data.Ratio
import Text.ParserCombinators.Parsec hiding (spaces)
data Env = Environment {
parentEnv :: (Maybe Env),
bindings :: (IORef (Data.Map.Map (String, String) (IORef LispVal)))
}
nullEnv :: IO Env
nullEnv = do nullBindings <- newIORef $ Data.Map.fromList []
return $ Environment Nothing nullBindings
macroNamespace :: [Char]
macroNamespace = "m"
varNamespace :: [Char]
varNamespace = "v"
data LispError = NumArgs Integer [LispVal]
| TypeMismatch String LispVal
| Parser ParseError
| BadSpecialForm String LispVal
| NotFunction String String
| UnboundVar String String
| DivideByZero
| NotImplemented String
| InternalError String
| Default String
showError :: LispError -> String
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
showError (BadSpecialForm message form) = message ++ ": " ++ show form
showError (NotFunction message func) = message ++ ": " ++ show func
showError (UnboundVar message varname) = message ++ ": " ++ varname
showError (DivideByZero) = "Division by zero"
showError (NotImplemented message) = "Not implemented: " ++ message
showError (InternalError message) = "An internal error occurred: " ++ message
showError (Default message) = "Error: " ++ message
instance Show LispError where show = showError
instance Error LispError where
noMsg = Default "An error has occurred"
strMsg = Default
type ThrowsError = Either LispError
trapError ::
(MonadError e m, Show e) =>
m String -> m String
trapError action = catchError action (return . show)
extractValue :: ThrowsError a -> a
extractValue (Right val) = val
extractValue (Left _) = error "Unexpected error in extractValue; "
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
data LispVal = Atom String
| List [LispVal]
| DottedList [LispVal] LispVal
| Vector (Array Int LispVal)
| HashTable (Data.Map.Map LispVal LispVal)
| Number Integer
| Float Double
| Complex (Complex Double)
| Rational Rational
| String String
| Char Char
| Bool Bool
| PrimitiveFunc ([LispVal] -> ThrowsError LispVal)
| Func {params :: [String],
vararg :: (Maybe String),
body :: [LispVal],
closure :: Env
}
| HFunc {hparams :: [String],
hvararg :: (Maybe String),
hbody :: (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal),
hclosure :: Env
}
| IOFunc ([LispVal] -> IOThrowsError LispVal)
| EvalFunc ([LispVal] -> IOThrowsError LispVal)
| Port Handle
| Continuation { closure :: Env
, currentCont :: (Maybe DeferredCode)
, nextCont :: (Maybe LispVal)
, extraReturnArgs :: (Maybe [LispVal])
, dynamicWind :: (Maybe [DynamicWinders])
}
| Syntax { synClosure :: Maybe Env
, synRenameClosure :: Maybe Env
, synDefinedInMacro :: Bool
, synIdentifiers :: [LispVal]
, synRules :: [LispVal]
}
| EOF
| Nil String
data DeferredCode =
SchemeBody [LispVal] |
HaskellBody {
contFunction :: (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
, contFunctionArgs :: (Maybe [LispVal])
}
data DynamicWinders = DynamicWinders {
before :: LispVal
, after :: LispVal
}
showDWVal :: DynamicWinders -> String
showDWVal (DynamicWinders b a) = "(" ++ (show b) ++ " . " ++ (show a) ++ ")"
instance Show DynamicWinders where show = showDWVal
makeNullContinuation :: Env -> LispVal
makeNullContinuation env = Continuation env Nothing Nothing Nothing Nothing
makeCPS :: Env -> LispVal -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal) -> LispVal
makeCPS env cont@(Continuation _ _ _ _ dynWind) cps = Continuation env (Just (HaskellBody cps Nothing)) (Just cont) Nothing dynWind
makeCPS env cont cps = Continuation env (Just (HaskellBody cps Nothing)) (Just cont) Nothing Nothing
makeCPSWArgs :: Env -> LispVal -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal) -> [LispVal] -> LispVal
makeCPSWArgs env cont@(Continuation _ _ _ _ dynWind) cps args = Continuation env (Just (HaskellBody cps (Just args))) (Just cont) Nothing dynWind
makeCPSWArgs env cont cps args = Continuation env (Just (HaskellBody cps (Just args))) (Just cont) Nothing Nothing
instance Ord LispVal where
compare (Bool a) (Bool b) = compare a b
compare (Number a) (Number b) = compare a b
compare (Rational a) (Rational b) = compare a b
compare (Float a) (Float b) = compare a b
compare (String a) (String b) = compare a b
compare (Char a) (Char b) = compare a b
compare (Atom a) (Atom b) = compare a b
compare a b = compare (show a) (show b)
eqv :: [LispVal] -> ThrowsError LispVal
eqv [(Bool arg1), (Bool arg2)] = return $ Bool $ arg1 == arg2
eqv [(Number arg1), (Number arg2)] = return $ Bool $ arg1 == arg2
eqv [(Complex arg1), (Complex arg2)] = return $ Bool $ arg1 == arg2
eqv [(Rational arg1), (Rational arg2)] = return $ Bool $ arg1 == arg2
eqv [(Float arg1), (Float arg2)] = return $ Bool $ arg1 == arg2
eqv [(String arg1), (String arg2)] = return $ Bool $ arg1 == arg2
eqv [(Char arg1), (Char arg2)] = return $ Bool $ arg1 == arg2
eqv [(Atom arg1), (Atom arg2)] = return $ Bool $ arg1 == arg2
eqv [(DottedList xs x), (DottedList ys y)] = eqv [List $ xs ++ [x], List $ ys ++ [y]]
eqv [(Vector arg1), (Vector arg2)] = eqv [List $ (elems arg1), List $ (elems arg2)]
eqv [(HashTable arg1), (HashTable arg2)] =
eqv [List $ (map (\ (x, y) -> List [x, y]) $ Data.Map.toAscList arg1),
List $ (map (\ (x, y) -> List [x, y]) $ Data.Map.toAscList arg2)]
--FUTURE:
eqv [x@(Func _ _ xBody _), y@(Func _ _ yBody _)] = do
if (show x) /= (show y)
then return $ Bool False
else eqvList eqv [List xBody, List yBody]
eqv [x@(HFunc _ _ xBody _), y@(Func _ _ yBody _)] = do
if (show x) /= (show y)
then return $ Bool False
else return $ Bool True
eqv [x@(PrimitiveFunc _), y@(PrimitiveFunc _)] = return $ Bool $ (show x) == (show y)
eqv [x@(IOFunc _), y@(IOFunc _)] = return $ Bool $ (show x) == (show y)
eqv [x@(EvalFunc _), y@(EvalFunc _)] = return $ Bool $ (show x) == (show y)
eqv [l1@(List _), l2@(List _)] = eqvList eqv [l1, l2]
eqv [_, _] = return $ Bool False
eqv badArgList = throwError $ NumArgs 2 badArgList
eqvList :: ([LispVal] -> ThrowsError LispVal) -> [LispVal] -> ThrowsError LispVal
eqvList eqvFunc [(List arg1), (List arg2)] = return $ Bool $ (length arg1 == length arg2) &&
(all eqvPair $ zip arg1 arg2)
where eqvPair (x1, x2) = case eqvFunc [x1, x2] of
Left _ -> False
Right (Bool val) -> val
_ -> False
eqvList _ _ = throwError $ Default "Unexpected error in eqvList"
eqVal :: LispVal -> LispVal -> Bool
eqVal a b = do
let result = eqv [a, b]
case result of
Left _ -> False
Right (Bool val) -> val
_ -> False
instance Eq LispVal where
x == y = eqVal x y
showVal :: LispVal -> String
showVal (Nil _) = ""
showVal (EOF) = "#!EOF"
showVal (String contents) = "\"" ++ contents ++ "\""
showVal (Char chr) = [chr]
showVal (Atom name) = name
showVal (Number contents) = show contents
showVal (Complex contents) = (show $ realPart contents) ++ "+" ++ (show $ imagPart contents) ++ "i"
showVal (Rational contents) = (show (numerator contents)) ++ "/" ++ (show (denominator contents))
showVal (Float contents) = show contents
showVal (Bool True) = "#t"
showVal (Bool False) = "#f"
showVal (Vector contents) = "#(" ++ (unwordsList $ Data.Array.elems contents) ++ ")"
showVal (HashTable _) = "<hash-table>"
showVal (List contents) = "(" ++ unwordsList contents ++ ")"
showVal (DottedList h t) = "(" ++ unwordsList h ++ " . " ++ showVal t ++ ")"
showVal (PrimitiveFunc _) = "<primitive>"
showVal (Continuation _ _ _ _ _) = "<continuation>"
showVal (Syntax _ _ _ _ _) = "<syntax>"
showVal (Func {params = args, vararg = varargs, body = _, closure = _}) =
"(lambda (" ++ unwords (map show args) ++
(case varargs of
Nothing -> ""
Just arg -> " . " ++ arg) ++ ") ...)"
showVal (HFunc {hparams = args, hvararg = varargs, hbody = _, hclosure = _}) =
"(lambda (" ++ unwords (map show args) ++
(case varargs of
Nothing -> ""
Just arg -> " . " ++ arg) ++ ") ...)"
showVal (Port _) = "<IO port>"
showVal (IOFunc _) = "<IO primitive>"
showVal (EvalFunc _) = "<procedure>"
unwordsList :: [LispVal] -> String
unwordsList = unwords . map showVal
instance Show LispVal where show = showVal