Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
520 lines (420 sloc) 19 KB
{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}
import System.Environment
import Text.ParserCombinators.Parsec hiding ( spaces )
import Monad
import Control.Monad.Error
import IO hiding (try)
import Data.IORef
import System.Random
import Control.Concurrent
import Foreign.C.Types
import Foreign.C.String
import Foreign.Ptr
import Network
import System.IO
import Data.IORef
import System.IO.Unsafe
foreign import ccall safe "openWindow" openWindow
:: IO CInt
data ViewController_struct
type ViewController = Ptr ViewController_struct
type RunStr = ViewController -> CString -> IO ()
foreign import ccall safe "wrapper" wrapFuncInvoke :: RunStr -> IO (FunPtr RunStr)
foreign import ccall safe "setLispEval" setLispEval :: ViewController -> FunPtr RunStr -> IO ()
foreign import ccall safe "addToResult" addToResult :: ViewController -> CString -> IO ()
data ObjCId_struct
type ObjCId = Ptr ObjCId_struct
data ObjCSEL_struct
type ObjCSEL = Ptr ObjCSEL_struct
foreign import ccall safe "objc_msgSend" objc_msgSend :: ObjCId -> ObjCSEL -> IO ObjCId
foreign import ccall safe "objc_msgSend" objc_msgSendInt :: ObjCId -> ObjCSEL -> Int -> IO ObjCId
foreign import ccall safe "sel_registerName" sel_registerName :: CString -> IO ObjCSEL
foreign import ccall safe "objc_lookUpClass" objc_lookUpClass :: CString -> IO ObjCId
makeAString :: IO ObjCId
makeAString = do
strCls <- withCString "NSString" objc_lookUpClass
allocName <- withCString "alloc" sel_registerName
alloced <- objc_msgSend strCls allocName
hPutStrLn stderr "Alloced it"
initName <- withCString "init" sel_registerName
objc_msgSend alloced initName
openLogger :: IO Handle
openLogger = return stderr
type ViewDidLoad = ViewController -> IO ()
foreign import ccall safe "wrapper" mkViewDidLoad :: ViewDidLoad -> IO (FunPtr ViewDidLoad)
foreign import ccall safe "setViewDidLoad" setViewDidLoad :: FunPtr ViewDidLoad -> IO ()
foreign import ccall safe "dispatchFunc" dispatchFunc :: FunPtr StrVoid -> IO ()
type StrVoid = CString -> IO ()
foreign import ccall safe "wrapper" mkStrCB :: StrVoid -> IO (FunPtr StrVoid)
foreign export ccall releaseMe :: FunPtr a -> IO ()
releaseMe :: FunPtr a -> IO ()
releaseMe ptr = freeHaskellFunPtr ptr
myThread :: IO ()
myThread = do
str <- makeAString
log <- openLogger
rSalt <- getStdRandom (randomR (1,1000000))
threadDelay $ 1000000 + rSalt
runOnMain $ appendStr $ "\nHello dude " ++ show rSalt
myThread
runOnMain :: IO () -> IO ()
runOnMain todo = do
func <- funky
dispatchFunc func
where funky = mkStrCB $ \v -> do
todo
--func <- funky
--freeHaskellFunPtr func
viewController :: IORef (Maybe ViewController)
viewController = unsafePerformIO $ newIORef Nothing
appendStr :: String -> IO ()
appendStr str = do
vcm <- readIORef viewController
case vcm of
Just vc -> withCString str $ \cstr -> addToResult vc cstr
_ -> return ()
main :: IO ()
main = do
log <- openLogger
hPutStrLn log "Starting the Lisp system"
env <- primitiveBindings -- the Lisp environment
-- execute a line of List and call the callback with the result
runALine <- wrapFuncInvoke $ \vc line -> do
writeIORef viewController $ Just vc
toEval <- peekCString line
res <- evalString env toEval
appendStr res
forkOS myThread
-- the initial callback that sets up the rest
vdl <- mkViewDidLoad $ \vc -> do
hPutStrLn log $ show vc++" viewDidLoad called back"
setLispEval vc runALine
return ()
setViewDidLoad vdl
openWindow
hPutStrLn log "Shutting down"
return ()
symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=?>@^_~#"
readOrThrow parser input = case parse parser "lisp" input of
Left err -> throwError $ Parser err
Right val -> return val
readExpr = readOrThrow parseExpr
readExprList = readOrThrow (endBy parseExpr spaces)
--readExpr :: String -> ThrowsError LispVal
--readExpr input = case parse parseExpr "lisp" input of
-- Left err -> throwError $ Parser err
-- Right val -> return val
spaces :: Parser ()
spaces = skipMany1 space
data LispVal = Atom String
| List [LispVal]
| DottedList [LispVal] LispVal
| Number Integer
| String String
| Bool Bool
| PrimitiveFunc ([LispVal] -> ThrowsError LispVal)
| Func {params :: [String], vararg :: (Maybe String),
body :: [LispVal], closure :: Env}
| IOFunc ([LispVal] -> IOThrowsError LispVal)
| Port Handle
parseString :: Parser LispVal
parseString = do char '"'
x <- many (noneOf "\"")
char '"'
return $ String x
parseAtom :: Parser LispVal
parseAtom = do first <- letter <|> symbol
rest <- many (letter <|> digit <|> symbol)
let atom = [first] ++ rest
return $ case atom of
"#t" -> Bool True
"#f" -> Bool False
otherwise -> Atom atom
parseNumber :: Parser LispVal
parseNumber = liftM (Number . read) $ many1 digit
-- parseList :: Parser LispVal
parseList = liftM List $ sepBy parseExpr spaces
parseDottedList = do
head <- endBy parseExpr spaces
tail <- char '.' >> spaces >> parseExpr
return $ DottedList head tail
-- moo
parseQuoted = do
char '\''
x <- parseExpr
return $ List [Atom "quote", x]
parseExpr :: Parser LispVal
parseExpr = parseAtom
<|> parseString
<|> parseNumber
<|> parseQuoted
<|> do char '('
x <- (try parseList) <|> parseDottedList
char ')'
return x
showVal (String contents) = "\"" ++ contents ++ "\""
showVal (Atom name) = name
showVal (Number number) = show number
showVal (Bool True) = "#t"
showVal (Bool False) = "#f"
showVal (List contents) = "(" ++ unwordsList contents ++ ")"
showVal (DottedList head tail) = "(" ++ unwordsList head ++
" . " ++ showVal tail ++ ")"
showVal (PrimitiveFunc _) = "<primative>"
showVal (Func {params = args, vararg = varargs, body = body, closure = env}) =
"(lambda (" ++ unwords (map show args) ++
(case varargs of
Nothing -> ""
Just arg -> " . " ++ arg) ++ ") ...)"
showVal (Port _) = "<IO port>"
showVal (IOFunc _) = "<IO Primitive>"
unwordsList = unwords . map showVal
instance Show LispVal where show = showVal
eval :: Env -> LispVal -> IOThrowsError LispVal
eval env val@(String _) = return val
eval env val@(Number _) = return val
eval env val@(Bool _) = return val
eval env (Atom id) = getVar env id
eval env (List [Atom "load", String filename]) =
load filename >>= liftM last . mapM (eval env)
eval env (List [Atom "quote", val]) = return val
eval env (List [Atom "if", pred, conseq, alt]) =
do result <- eval env pred
case result of
Bool False -> eval env alt
_ -> eval env conseq
eval env (List [Atom "set!", Atom var, form]) = eval env form >>= setVar env var
eval env (List [Atom "define", Atom var, form]) = eval env form >>= defineVar env var
eval env (List (Atom "define" : List (Atom var : params) : body)) =
makeNormalFunc env params body >>= defineVar env var
eval env (List (Atom "define" : DottedList(Atom var : params) varargs : body)) =
makeVarargs varargs env params body >>= defineVar env var
eval env (List (Atom "lambda" : List params : body)) =
makeNormalFunc env params body
eval env (List (Atom "lambda" : DottedList params varargs : body)) =
makeVarargs varargs env params body
eval env (List (function : args)) = do
func <- eval env function
argVals <- mapM (eval env) args
apply func argVals
-- eval env (List [Atom "define", Atom var, form]) = eval env form >>= defineVar env var
-- eval env (List (Atom func : args)) = mapM (eval env) args >>= liftThrows . apply func
eval env badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm
--apply func args = maybe (throwError $ NotFunction
-- "Unrecognized primative function args" func)
-- ($ args) (lookup func primitives)
apply :: LispVal -> [LispVal] -> IOThrowsError LispVal
apply (PrimitiveFunc func) args = liftThrows $ func args
apply (Func params varargs body closure) args =
if num params /= num args && varargs == Nothing
then throwError $ NumArgs (num params) args
else (liftIO $ bindVars closure $ zip params args) >>= bindVarArgs varargs >>= evalBody
where remainingArgs = drop (length params) args
num = toInteger . length
evalBody env = liftM last $ mapM (eval env) body
bindVarArgs arg env = case arg of
Just argName -> liftIO $ bindVars env [(argName, List $ remainingArgs)]
Nothing -> return env
primitives = [("+", numericBinop (+)),
("-", numericBinop (-)),
("*", numericBinop (*)),
-- ("/", numericBinop (/)),
("mod", numericBinop mod),
("=", numBoolBinop (==)),
("<", numBoolBinop (<)),
(">", numBoolBinop (>)),
("/=", numBoolBinop (/=)),
(">=", numBoolBinop (>=)),
("<=", numBoolBinop (<=)),
("&&", boolBoolBinop (&&)),
("||", boolBoolBinop (||)),
("string=?", strBoolBinop (==)),
("string?", strBoolBinop (>)),
("string<=?", strBoolBinop (<=)),
("string>=?", strBoolBinop (>=)),
("quotient", numericBinop quot),
("car", car),
("cdr", cdr),
("cons", cons),
("eq?", eqv),
("eqv?", eqv),
("equal?", equal),
("remainder", numericBinop rem)]
boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBinop unpacker op args = case args of
[a, b] -> do left <- unpacker a
right <- unpacker b
return $ Bool $ left `op` right
_ -> throwError $ NumArgs 2 args
numBoolBinop = boolBinop unpackNum
strBoolBinop = boolBinop unpackStr
boolBoolBinop = boolBinop unpackBool
numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal
numericBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal
numericBinop op params = mapM unpackNum params >>= return .
Number . foldl1 op
unpackStr (String s) = return s
unpackStr (Number n) = return $ show n
unpackStr (Bool b) = return $ show b
unpackStr notString = throwError $ TypeMismatch "string" notString
unpackBool (Bool b) = return b
unpackBool notBool = throwError $ TypeMismatch "boolean" notBool
-- unpackNum :: LispVal -> ThrowsError Integer
unpackNum (Number n) = return n
unpackNum (String s) = let parsed = reads s in
case parsed of
[(n,"")] -> return n
_ -> throwError $ TypeMismatch "number" $ String s
unpackNum (List [n]) = unpackNum n
unpackNum notNum = throwError $ TypeMismatch "number" notNum
car :: [LispVal] -> ThrowsError LispVal
car [List (x : xs)] = return x
car [DottedList (x : xs) _] = return x
car [badArg] = throwError $ TypeMismatch "pair" badArg
car badArgList = throwError $ NumArgs 1 badArgList
cdr [List (x : xs)] = return $ List xs
cdr [DottedList (_ : xs) x] = return $ DottedList xs x
cdr [DottedList [_] x] = return x
cdr [badArg] = throwError $ TypeMismatch "pair" badArg
cdr badArgList = throwError $ NumArgs 1 badArgList
cons :: [LispVal] -> ThrowsError LispVal
cons [x1, List []] = return $ List [x1]
cons [x, List xs] = return $ List $ [x] ++ xs
cons [x, DottedList xs xlast] = return $ DottedList ([x] ++ xs) xlast
cons [x1, x2] = return $ DottedList [x1] x2
cons badArgList = throwError $ NumArgs 2 badArgList
eqv :: [LispVal] -> ThrowsError LispVal
eqv [(Bool arg1), (Bool arg2)] = return $ Bool $ arg1 == arg2
eqv [(Number arg1), (Number arg2)] = return $ Bool $ arg1 == arg2
eqv [(String arg1), (String 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 [(List arg1), (List arg2)] = return $ Bool $
(length arg1 == length arg2) &&
(and $ map eqvPair $ zip arg1 arg2)
where eqvPair (x1, x2) = case eqv [x1, x2] of
Left err -> False
Right (Bool val) -> val
eqv [_, _] = return $ Bool False
eqv badArgList = throwError $ NumArgs 2 badArgList
data LispError = NumArgs Integer [LispVal]
| TypeMismatch String LispVal
| Parser ParseError
| BadSpecialForm String LispVal
| NotFunction String String
| UnboundVar String String
| Default 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 action = catchError action (return . show)
extractValue (Right val) = val
data Unpacker = forall a . Eq a => AnyUnpacker (LispVal -> ThrowsError a)
unpackEquals :: LispVal -> LispVal -> Unpacker -> ThrowsError Bool
unpackEquals arg1 arg2 (AnyUnpacker unpacker) =
do unpacked1 <- unpacker arg1
unpacked2 <- unpacker arg2
return $ unpacked1 == unpacked2
`catchError` (const $ return False)
equal :: [LispVal] -> ThrowsError LispVal
equal [arg1, arg2] = do
primitiveEquals <- liftM or $ mapM (unpackEquals arg1 arg2)
[AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool]
eqvEquals <- eqv [arg1, arg2]
return $ Bool $ (primitiveEquals || let (Bool x) = eqvEquals in x)
equal badArgList = throwError $ NumArgs 2 badArgList
flushStr :: String -> IO ()
flushStr str = putStr str >> hFlush stdout
readPrompt prompt = flushStr prompt >> getLine
until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m ()
until_ pred prompt action = do
result <- prompt
if pred result
then return ()
else action result >> until_ pred prompt action
type Env = IORef [(String, IORef LispVal)]
nullEnv = newIORef []
type IOThrowsError = ErrorT LispError IO
liftThrows :: ThrowsError a -> IOThrowsError a
liftThrows (Left err) = throwError err
liftThrows (Right val) = return val
runIOThrows action = runErrorT (trapError action) >>= return . extractValue
isBound envRef var = readIORef envRef >>= return . maybe False (const True) . lookup var
getVar envRef var = do env <- liftIO $ readIORef envRef
maybe (throwError $ UnboundVar "Getting an unbound variable" var)
(liftIO . readIORef)
(lookup var env)
setVar envRef var value = do env <- liftIO $ readIORef envRef
maybe (throwError $ UnboundVar "Setting an unbound variable" var)
(liftIO . (flip writeIORef value))
(lookup var env)
return value
applyProc [func, List args] = apply func args
applyProc (func : args) = apply func args
-- defineVar :: Env -> String -> 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 envRef bindings = readIORef envRef >>= extendEnv bindings >>= newIORef
where extendEnv bindings env = liftM (++ env) (mapM addBinding bindings)
addBinding (var, value) = do ref <- newIORef value
return (var, ref)
evalAndPrint env expr = evalString env expr >>= putStrLn
evalString :: Env -> String -> IO String
evalString env expr = runIOThrows $ liftM show $ (liftThrows $ readExpr expr) >>= eval env
runOne :: [String] -> IO ()
runOne args = do
env <- primitiveBindings >>= flip bindVars [("args", List $ map String $ drop 1 args)]
output <- (runIOThrows $ liftM show $ eval env (List [Atom "load", String (args !! 0)]))
hPutStrLn stderr output
-- >>= putStrLn stderr
runRepl = primitiveBindings >>= until_ (== "quit") (readPrompt "Lisp>>> ") . evalAndPrint
primitiveBindings :: IO Env
primitiveBindings = nullEnv >>= (flip bindVars $ map (makeFunc IOFunc) ioPrimitives
++ map (makeFunc PrimitiveFunc) primitives)
where makeFunc constructor (var, func) = (var, constructor func)
makeFunc varargs env params body = return $ Func (map showVal params) varargs body env
makeNormalFunc = makeFunc Nothing
makeVarargs = makeFunc . Just . showVal
ioPrimitives = [("apply", applyProc),
("open-input-file", makePort ReadMode),
("open-output-file", makePort WriteMode),
("close-input-port", closePort),
("close-output-port", closePort),
("read", readProc),
("write", writeProc),
("read-contents", readContents),
("read-all", readAll)]
makePort mode [String filename] = liftM Port $ liftIO $ openFile filename mode
closePort [Port port] = liftIO $ hClose port >> (return $ Bool True)
closePort _ = return $ Bool False
readProc [] = readProc [Port stdin]
readProc [Port port] = (liftIO $ hGetLine port) >>= liftThrows . readExpr
writeProc [obj] = writeProc [obj, Port stdout]
writeProc [obj, Port port] = liftIO $ hPrint port obj >> (return $ Bool True)
readContents [String filename] = liftM String $ liftIO $ readFile filename
load filename = (liftIO $ readFile filename) >>= liftThrows . readExprList
readAll [String filename] = liftM List $ load filename
Something went wrong with that request. Please try again.