Main.hs

module Main where

import Data.IORef
import Control.Monad.Error
import System.IO (hFlush, stdout)
import System.Environment (getArgs)

import Types
import Parser
import Prims

-- Main

main = do
  args <- getArgs
  case length args of
    0 -> repl
    1 -> defaultEnv >>= flip run (head args) >> return ()
    _ -> putStrLn "Invalid arguments."

repl :: IO ()
repl = do
  putStrLn "oct - a minimal lisp-dialect"
  putStrLn "----------------------------"
  env <- defaultEnv
  loop env
  where
    loop x = do
      putStr "> " >> hFlush stdout
      str <- getLine
      case str of
        "quit" -> return ()
        _ -> interpret x str >>= putStrLn >> loop x

interpret :: Env -> String -> IO String
interpret env exp =
  runIOErrorOr $ fmap show $ (liftErrorOr $ readExpr exp) >>= eval env

run :: Env -> String -> IO String
run env file =
  runIOErrorOr $ fmap show $ do
  exp <- (liftIO $ readFile file) >>= liftErrorOr . readExprFile
  _ <- fmap last . mapM (eval env) $ exp
  return ()

runIOErrorOr :: IOErrorOr String -> IO String
runIOErrorOr x =
 runErrorT (trapError x) >>= return . extractValue
  where
    extractValue (Right val) = val
    trapError x = catchError x (return . show)

-- Environment

nullEnv :: IO Env
nullEnv = newIORef []

checkVar :: Env -> String -> IO Bool
checkVar env x =
  readIORef env >>= return . maybe False (const True) . lookup x

getVar :: Env -> String -> IOErrorOr Expr
getVar envRef x = do
  env <- liftIO $ readIORef envRef
  maybe (throwError $ NotInScope x)
        (liftIO . readIORef)
        (lookup x env)

define :: Env -> String -> Expr -> IOErrorOr Expr
define env var exp = do
  x <- liftIO $ checkVar env var
  y <- liftIO $ readIORef env
  case x of
    True -> maybe (error "define")
                  (liftIO . flip writeIORef exp)
                  (lookup var y)
    False -> do z <- liftIO $ newIORef exp
                liftIO $ writeIORef env ((var,z):y)
  return exp

bind :: Env -> [(String, Expr)] -> IO Env
bind env xs = readIORef env >>= extEnv xs >>= newIORef
  where
    extEnv xs env = fmap (++ env) (mapM addBinds xs)
    addBinds (var, exp) = do x <- newIORef exp
                             return (var, x)

defaultEnv :: IO Env
defaultEnv = nullEnv >>= flip bind prims

-- Evaluation

eval :: Env -> Expr -> IOErrorOr Expr
eval env (Sym x) = getVar env x
eval env (List [Sym "fn", List params, List form]) =
  return $ Func env (map (\(Sym x) -> x) params) (List form)
eval env (List [Sym "if", pred, consq, alt]) = do
  result <- eval env pred
  case result of
    Bool True -> eval env consq
    Bool False -> eval env alt
eval env (List [Sym "def", Sym var, exp]) = define env var exp
eval env (List [Sym "defun", Sym var, List params, List form]) =
  define env var $ Func env (map (\(Sym x) -> x) params) (List form)
eval env (List [Sym "defmac", Sym var, List params, List form]) =
  define env var $ Macr env (map (\(Sym x) -> x) params) (List form)
eval env (List [Sym "quote", xs]) = return xs
eval env (List (op:args)) = do
  func <- eval env op
  case func of
    Macr {} -> expandMacr func args >>= eval env
    _ -> mapM (eval env) args >>= apply func
eval _ x = return x

apply :: Expr -> [Expr] -> IOErrorOr Expr
apply (Prim func) args = liftErrorOr $ func args
apply (Action func) args = func args
apply (Func env params form) args =
  case length params == length args of
    True -> (liftIO $ bind env $ zip params args)
            >>= flip eval form
    False -> throwError . NumArgs . toInteger $ length params
apply _ _ = error "apply"

expandMacr :: Expr -> [Expr] -> IOErrorOr Expr
expandMacr (Macr env params form) args =
  case length params == length args of
    True -> (liftIO $ bind env $ zip params args)
            >>= flip eval form
    False -> throwError . NumArgs . toInteger $ length params
expandMacr _ _ = error "expandMacr"

Prims.hs

module Prims (prims) where

import Control.Applicative ((<$>),(<$))
import Control.Monad.Error (throwError, liftIO)

import Types

prims = [
         -- Arithmetic functions
         ("+", Prim $ arith (+)),
         ("-", Prim $ arith (-)),
         ("/", Prim $ arith div),
         ("*", Prim $ arith (*)),
         ("%", Prim $ arith mod),
         ("<", Prim $ numBool (<)),
         (">", Prim $ numBool (>)),
         -- Univarsal equality function
         ("=", Prim equal),
         -- Boolean functions
         ("&", Prim $ bool (&&)),
         ("|", Prim $ bool (||)),
         -- List functions
         ("list", Prim list),
         ("cons", Prim cons),
         ("car", Prim car),
         ("cdr", Prim cdr),
         -- I/O functions
         ("print", Action print'),
         ("read", Action read')]

arith :: (Int -> Int -> Int) -> [Expr] -> ErrorOr Expr
arith f [] = throwError $ NumArgs 2
arith f x@[_] = throwError $ NumArgs 2
arith f params = return . Num . foldl1 f $ (\(Num x) -> x) <$> params

numBool :: (Int -> Int -> Bool) -> [Expr] -> ErrorOr Expr
numBool f [Num x, Num y] = return . Bool $ f x y
numBool f [_,_] = throwError $ TypeMismatch "num"
numBool f _ = throwError $ NumArgs 2

equal :: [Expr] -> ErrorOr Expr
equal [Bool x, Bool y] = return . Bool $ x == y
equal [Num x, Num y] = return . Bool $ x == y
equal [Str x, Str y] = return . Bool $ x == y
equal [Sym x, Sym y] = return . Bool $ x == y
equal [List x, List y] =
  return . Bool $ eqLength x y && (and $ map eqvPair $ zip x y)
  where
    eqLength z q = length z == length q
    eqvPair (z,q) = case equal [z,q] of
                      Left _ -> False
                      Right (Bool v) -> v
equal [_,_] = return $ Bool False
equal _ = throwError $ NumArgs 2

bool :: (Bool -> Bool -> Bool) -> [Expr] -> ErrorOr Expr
bool f [] = throwError $ NumArgs 2
bool f x@[_] = throwError $ NumArgs 2
bool f [Bool x, Bool y] = return . Bool $ f x y
bool f [_,_] = throwError $ TypeMismatch "bool"

list :: [Expr] -> ErrorOr Expr
list [xs] = return $ List [xs]
list _ = throwError $ NumArgs 1

cons :: [Expr] -> ErrorOr Expr
cons [x, List []] = return $ List [x]
cons [x, List xs] = return . List $ [x] ++ xs
cons _ = throwError $ NumArgs 2

car :: [Expr] -> ErrorOr Expr
car [List (x:xs)] = return x
car [_] = throwError $ TypeMismatch "list"
car _ = throwError $ NumArgs 1

cdr :: [Expr] -> ErrorOr Expr
cdr [List (x:xs)] = return $ List xs
cdr [_] = throwError $ TypeMismatch "list"
cdr _ = throwError $ NumArgs 1

print' :: [Expr] -> IOErrorOr Expr
print' [Str x] = Bool True <$ (liftIO $ putStrLn x)
print' [_] = throwError $ TypeMismatch "string"
print' _ = throwError $ NumArgs 1

read' :: [Expr] -> IOErrorOr Expr
read' [] = liftIO getLine >>= return . Str
read' _ = throwError $ NumArgs 0