Main.hs

{-# 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