lisp written in haskell
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 

222 lines
7.0 KiB

import Data.Char
import qualified Data.Map as Map
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import System.Console.Haskeline
-- Testing
data LispTree
= LispList [LispTree]
| LispInteger Integer
| LispSymbol String
| LispKeyword String
| LispArray [LispTree]
| LispString String
| LispError String
| LispNil
| LispFunction { fn :: ([LispTree] -> IO LispTree)
, ast :: [LispTree]
, args :: [String]
}
deriving ()
instance Num LispTree where
(LispInteger a) + (LispInteger b) = LispInteger (a + b)
_ + _ = LispNil
(LispInteger a) - (LispInteger b) = LispInteger (a - b)
_ - _ = LispNil
(LispInteger a) * (LispInteger b) = LispInteger (a * b)
_ * _ = LispNil
negate (LispInteger x) = LispInteger 0 - LispInteger x
negate _ = LispNil
fromInteger x = LispInteger x
signum (LispInteger x)
| x < 0 = LispInteger 0-1
| x == 0 = LispInteger 0
| x > 0 = LispInteger 1
signum _ = LispNil
abs (LispInteger x) = LispInteger (abs x)
abs _ = LispNil
instance Show LispTree where
show (LispList x) = "(" ++ unwords (map show x) ++ ")"
show (LispInteger x) = show x
show (LispSymbol x) = x
show (LispKeyword x) = ":" ++ x
show (LispArray x) = "[" ++ unwords (map show x) ++ "]"
show (LispString x) = show x
show (LispError x) = "ERROR: " ++ x
show LispNil = "nil"
show (LispFunction _ _ _) = "<lisp function>"
-- Envs
type Env = Map.Map String LispTree
addFn :: [LispTree] -> IO LispTree
addFn xs = return (sum xs)
subFn :: [LispTree] -> IO LispTree
subFn (x:xs) = return $ foldl (-) x xs
mulFn :: [LispTree] -> IO LispTree
mulFn (x:xs) = return $ foldl (*) x xs
printFn :: [LispTree] -> IO LispTree
printFn xs = printFn' xs
where
printFn' (LispString x:xs) = do
putStr x
printFn' xs
printFn' (x:xs) = do
putStr . show $ x
printFn' xs
printFn' [] = do
putStrLn ""
return LispNil
inputFn :: [LispTree] -> IO LispTree
inputFn ((LispString s):_) = do
putStr s
line <- getLine
return $ LispString line
inputFn _ = do
line <- getLine
return $ LispString line
commentFn :: [LispTree] -> IO LispTree
commentFn _ = return LispNil
absFn (LispInteger x:_) = return $ LispInteger (abs x)
absFn _ = return LispNil
doFn :: [LispTree] -> IO LispTree
doFn xs = return $ last xs
base_env :: Env
base_env = Map.fromList [("nil", LispNil)
,("+", LispFunction addFn [] [])
,("-", LispFunction subFn [] [])
,("*", LispFunction mulFn [] [])
,("abs", LispFunction absFn [] [])
,("print", LispFunction printFn [] [])
,("input", LispFunction inputFn [] [])
,("do", LispFunction doFn [] [])
,("--", LispFunction commentFn [] [])]
-- REPL function
lispREPL = runInputT defaultSettings lispREPL'
where
crashHandler e = do
return (LispError (show (e :: SomeException)))
lispREPL' = do
line <- getInputLine "lisp> "
case line of
Just "quit" -> return ()
Just x -> do
result <- catch (liftIO $ evalLisp x) crashHandler
outputStrLn $ show result
lispREPL'
Nothing -> return ()
evalLisp = runAST base_env. makeLispAST . tokenize
tokenize :: String -> [String]
tokenize s = filter (/= "") $ tokenize' (reverse s) [""]
where
appendToken ("":xs) ch = "":[ch]:xs
appendToken (x:xs) ch = "":[ch]:x:xs
trimLeft (x:xs)
| isSpace x = trimLeft xs
| otherwise = xs
trimRight = reverse . trimLeft . reverse
trim = trimLeft . trimRight
getEscape e = case e of
'n' -> '\10'
'r' -> '\13'
'0' -> '\0'
'\\' -> '\\'
'\'' -> '\''
'"' -> '"'
parseString (r, (e:'\\':s)) = parseString ((getEscape e:r), s)
parseString (r, ('"':s)) = (r, s)
parseString (r, "") = error "Mismatched doublequotes"
parseString (r, (ch:s)) = parseString (ch:r, s)
tokenize' (ch:s) (x:xs)
| isSpace ch = tokenize' s $
(if x /= "" then "":x:xs else x:xs)
tokenize' (ch:s) acc
| ch `elem` "()[]{}," = tokenize' s $ appendToken acc ch
| ch == '"' = let (ss, sss) = parseString ("", s) in
tokenize' sss $ ('"':ss):acc
tokenize' (ch:s) (x:xs) = tokenize' s $ (ch:x):xs
tokenize' "" acc = acc
makeLispAST :: [String] -> [LispTree]
makeLispAST s = if matchingBrackets then fst $ makeLispAST' [] s
else error "Mismatching brackets."
where
getLispValueType (x:xs) = case x of
'"' -> LispString xs
':' -> LispKeyword xs
_ -> if all isDigit (x:xs) then LispInteger (read (x:xs))
else LispSymbol (x:xs)
nestedList xss = makeLispAST' [] xss
count xs s = sum $ map (fromEnum . (== s)) xs
matchingBrackets = (count s "[") == (count s "]") &&
(count s "(") == (count s ")")
makeLispAST' :: [LispTree] -> [String] -> ([LispTree], [String])
makeLispAST' acc (xs:xss)
| xs `elem` ["(", "["] = let
(r, rxs) = nestedList xss
rr = if xs == "(" then LispList r else LispArray r
in makeLispAST' (rr:acc) rxs
makeLispAST' acc (x:xss)
| x `elem` [")", "]"] = (reverse acc, xss)
makeLispAST' acc [] = (reverse acc, [])
makeLispAST' acc (xs:xss)
= makeLispAST' (r:acc) xss
where
r = getLispValueType xs
runAST env xs = do
result <- evalAST xs env
return (head result)
evalAST :: [LispTree] -> Env -> IO [LispTree]
evalAST xs env = sequence $ map evalAST' xs
where
getVar x = case (Map.lookup x env) of
Just x -> x
Nothing -> error $ "'" ++ x ++ "' not in scope."
evalAST' :: LispTree -> IO LispTree
evalAST' (LispList s) = do
let (LispSymbol fname) = head s
let LispFunction f _ _ = getVar fname
args <- evalAST (tail s) env
f args
evalAST' (LispArray s) = do
ast <- evalAST s env
return $ LispArray ast
evalAST' (LispSymbol s) = return $ getVar s
evalAST' s = return $ s
-----------
-----------
-----------
main = lispREPL