{- an effort to make some sort of scheme environments in haskell for an interpreter -} import IO import Data.IORef import System.IO.Unsafe import Monad import Text.ParserCombinators.Parsec as P import Text.ParserCombinators.Parsec.Token data LispVal = Cons (IORef LispVal) (IORef LispVal) | Null | Number SchemeNumber | Bool Bool | Atom String | PrimitiveLambda ([LispVal]->IO LispVal) | Lambda { args::LispVal, body::[LispVal], env::Env } data SchemeNumber = Integer Integer | Double Double data Env = Environment {parentEnv :: (Maybe Env), bindings :: (IORef [(String, IORef LispVal)])} nullEnv :: IO Env nullEnv = do bindings <- newIORef [] return $ Environment Nothing bindings extendEnv :: [(String, LispVal)] -> Env -> IO Env extendEnv bindings envRef = do bindinglist <- mapM (\(name, val) -> do ref <- newIORef val return (name, ref)) bindings >>= newIORef return $ Environment (Just envRef) bindinglist envLookup :: String -> Env -> IO LispVal envLookup name env = do binds <- readIORef $ bindings env case lookup name binds of (Just a) -> readIORef a Nothing -> case parentEnv env of (Just par) -> envLookup name par Nothing -> error $ "lookup: no binding " ++ name envDefine :: String -> LispVal -> Env -> IO LispVal envDefine name val env = do binds <- readIORef $ bindings env case lookup name binds of (Just a) -> writeIORef a val Nothing -> do v <- newIORef val writeIORef (bindings env) ((name, v):binds) return $ Atom name envSet :: String -> LispVal -> Env -> IO LispVal envSet name val env = do binds <- readIORef $ bindings env case lookup name binds of (Just a) -> do vprime <- readIORef a writeIORef a val return vprime Nothing -> case parentEnv env of (Just par) -> envSet name val par Nothing -> error $ "set: no binding " ++ name paramZip :: LispVal -> [LispVal] -> IO [(String, LispVal)] paramZip (Atom s) v = do r <- listToCons v return [(s, r)] paramZip a@(Cons _ _) (first:rest) = do name <- car a >>= (\(Atom s) -> return s) restNames <- cdr a case restNames of Null -> return $ [(name, first)] otherwise -> do restEnv <- paramZip restNames rest return $ (name, first):restEnv display :: LispVal -> IO String display Null = return "'()" display (Number n) = return $ show n display (Atom s) = return s display v@(Cons _ _) = do s <- partialDisplay v return $ "(" ++ s where partialDisplay (Cons car cdr) = do l <- readIORef car >>= display r <- readIORef cdr case r of Null -> return $ l ++ ")" (Cons _ _) -> do rs <- partialDisplay r return $ l ++ " " ++ rs otherwise -> do rs <- display r return $ l ++ " . " ++ rs ++ ")" instance Show LispVal where show Null = "'()" show (Number n) = show n show (Atom s) = s show (Bool b) = if b then "#t" else "#f" show v@(Cons _ _) = "(" ++ (unsafePerformIO $ partialShow v) where partialShow cell = do l <- liftM show $ car cell r <- cdr cell case r of Null -> return $ l ++")" (Cons _ _) -> do rs <- partialShow r return $ l ++ " " ++ rs otherwise -> return $ l ++ " . " ++ (show r) ++ ")" show (Lambda args body _) = "(lambda "++(show args)++" ...)" instance Show SchemeNumber where show (Integer n) = show n show (Double n) = show n car :: LispVal -> IO LispVal car (Cons a b) = readIORef a cdr :: LispVal -> IO LispVal cdr (Cons a b) = readIORef b cons :: LispVal -> LispVal -> IO LispVal cons a b = do f <- newIORef a s <- newIORef b return $ Cons f s ucons :: LispVal -> LispVal -> LispVal ucons a b = unsafePerformIO $ cons a b listToCons :: [LispVal] -> IO LispVal listToCons [] = return Null listToCons (v:rest) = do r <- listToCons rest cons v r consToList :: LispVal -> IO [LispVal] consToList (Cons a b) = do car <- readIORef a cdr <- readIORef b case cdr of Null -> return $ car:[] (Cons _ _) -> do rest <- consToList cdr return $ car:rest otherwise -> error "bad list" consToList Null = return $ [] {- example (this is so a parser isn't needed for testing) listToCons (L [A (Atom "+"), A (Number 2), A (Number 3)]) >>= display "(+ 2 3)" -} main :: IO () main = do env <- nullEnv >>= extendEnv primitives repl env repl :: Env -> IO () repl env = do putStr "\n==> " a <- getLine case (parse lispReadSequence "" a) of Left err -> print err Right sexps -> do val <- mapM (\x -> eval x env) sexps putStr "\n;Value: " putStrLn $ show $ last val repl env -- -- Let's read -- lispReadSequence :: Parser [LispVal] lispReadSequence = P.try (do skipMany space eof return []) <|> (do e <- lispRead rest <- lispReadSequence return $ e:rest) lispRead :: Parser LispVal lispRead = do skipMany space readNumber <|> readHash <|> readAtom <|> readQuote <|> readParens schemeSymbols = oneOf "!$%&*+-./:<=>?@^_~" lispLexer = makeTokenParser $ LanguageDef { commentStart = "#|" , commentEnd = "|#" , commentLine = ";" , nestedComments = True , identStart = letter <|> schemeSymbols , identLetter = alphaNum <|> schemeSymbols , opStart = oneOf "" , opLetter = oneOf "" , reservedNames = [] , reservedOpNames = [] , caseSensitive = True } readNumber :: Parser LispVal readNumber = P.try (do op <- option '+' (char '-') num <- naturalOrFloat lispLexer return $ Number $ case num of Left int -> Integer $ if op=='-' then negate int else int Right doub -> Double $ if op=='-' then negate doub else doub) readHash = do char '#' ident <- identifier lispLexer case ident of "t" -> return $ Bool True "f" -> return $ Bool False readAtom :: Parser LispVal readAtom = do s <- identifier lispLexer return $ Atom s readQuote :: Parser LispVal readQuote = do t <- oneOf "'`," rest <- lispRead return $ ucons (Atom $ case t of '\'' -> "quote" '`' -> "quasiquote" ',' -> "unquote") (ucons rest Null) readParens :: Parser LispVal readParens = do char '(' readSExp readSExp :: Parser LispVal readSExp = P.try (do char '.' skipMany1 space v <- lispRead skipMany1 space char ')' return v) <|> (do car <- lispRead cdr <- (char ')' >>= return . Left) <|> (readSExp >>= return . Right) case cdr of Left _ -> return $ ucons car Null Right cdrP -> return $ ucons car cdrP) -- -- Let's eval -- eval :: LispVal -> Env -> IO LispVal eval (Number n) env = return $ Number n eval (Bool n) env = return $ Bool n eval (Atom n) env = envLookup n env eval c@(Cons _ _) env = do args <- consToList c seval args env seval :: [LispVal] -> Env -> IO LispVal seval [Atom "quote", a] env = return a seval [Atom "set!", Atom name, val] env = do evalVal <- eval val env envSet name evalVal env seval [Atom "define", Atom name, val] env = do evalVal <- eval val env envDefine name evalVal env seval (Atom "define":(Cons n a):body) env = do (Atom name) <- readIORef n args <- readIORef a envDefine name (Lambda args body env) env seval (Atom "lambda":args:body) env = return $ Lambda args body env seval (Atom "begin":body) env = executeBegin body env seval [Atom "if",pred,conseq,alt] env = do p <- eval pred env >>= (\v -> case v of (Bool False) -> return False otherwise -> return True) eval (if p then conseq else alt) env seval xs env = do exprs <- mapM (\exp -> eval exp env) xs (\(proc:args) -> apply proc args) exprs -- -- Let's apply -- apply :: LispVal -> [LispVal] -> IO LispVal apply (PrimitiveLambda p) args = p args apply (Lambda fargs body env) args = do bindings <- paramZip fargs args env2 <- extendEnv bindings env executeBegin body env2 apply p args = error "Unknown procedure type" executeBegin :: [LispVal] -> Env -> IO LispVal executeBegin [v] env = eval v env executeBegin (v:rest) env = do eval v env executeBegin rest env -- -- Primitives -- primitives :: [(String, LispVal)] primitives = [ ("+", numericBinop (+)) , ("-", numericBinop (-)) , ("*", numericBinop (*)) , ("/", numericBinop div) , ("<", numericBinBool (<)) , ("==", numericBinBool (==)) ] numericBinop :: (Integer -> Integer -> Integer) -> LispVal numericBinop op = PrimitiveLambda (\args -> return $ Number $ foldl1 sop $ map (\(Number n) -> n) args) where sop :: SchemeNumber -> SchemeNumber -> SchemeNumber sop (Integer n1) (Integer n2) = Integer $ op n1 n2 numericBinBool :: (Integer -> Integer -> Bool) -> LispVal numericBinBool op = PrimitiveLambda (\ [(Number (Integer arg1)),(Number (Integer arg2))] -> return $ Bool $ op arg1 arg2)