oct.hs

module Main where

import Control.Applicative ((<$>))
import Control.Monad.Error
import Text.ParserCombinators.Parsec
import Data.IORef

-- Types

data Expr
  = Sym String
  | List [Expr]
  | Num Int
  | Str String
  | Bool Bool
  | Func Env [String] Expr
  | Prim ([Expr] -> ErrorOr Expr)

instance Show Expr where
  show exp =
    case exp of
      Sym x -> x
      List xs -> "(" ++ (unwords $ map show xs) ++ ")"
      Num x -> show x
      Str x -> "\"" ++ x ++ "\""
      Bool x -> show x
      Func _ _ _ -> "a function"
      Prim _ -> "a primitive"

data Err
  = NotInScope String
  | TypeMismatch String
  | NumArgs Integer 
  | Parser ParseError
  | Default String
    deriving (Show)

instance Error Err

type ErrorOr = Either Err

type IOErrorOr = ErrorT Err IO

liftToIO :: ErrorOr a -> IOErrorOr a
liftToIO (Left x) = throwError x
liftToIO (Right x) = return x

-- Environment

type Env = IORef [(String, IORef Expr)]

nullEnv :: IO Env
nullEnv = newIORef []

lookupEnv :: Env -> String -> IO (Maybe Expr)
lookupEnv env x = readIORef env >>= return . lookup x

define :: Env -> String -> Expr -> IOErrorOr Expr
define env var exp = do
  x <- lookupEnv env var
  y <- readIORef env
  z <- newIORef exp
  writeIORef y ((var,z):env)
  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) = do
  res <- lookupEnv env x
  case res of
    Just _ -> return $ Sym x
    Nothing -> throwError $ NotInScope 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 "quote", xs]) = return xs
eval env (List (op:args)) = do
  func <- eval env op
  args <- mapM (eval env) args
  apply func args
eval env x = return x

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

-- Primitives

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
         ("cons", Prim cons),
         ("car", Prim car),
         ("cdr", Prim cdr)]

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

{- TODO: Make so it works on any amount of arguments
   (= 2 3 4 5)
   Should be possible for example -}
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"

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

-- Parser

readExpr :: String -> ErrorOr Expr
readExpr x =
  case parse parseExpr "lisp" x of
    Left err -> throwError $ Parser err
    Right y -> return y

symbol :: Parser Char
symbol = oneOf "!#$%&|*+-/:<=>?@^_~"

parseSym :: Parser Expr
parseSym = do
  x <- letter <|> symbol
  y <- many $ letter <|> digit <|> symbol
  return . Sym $ [x] ++ y

parseNum :: Parser Expr
parseNum = do
  x <- many1 digit
  return . Num $ read x

parseStr :: Parser Expr
parseStr = do
  char '"'
  x <- many $ noneOf "\""
  char '"'
  return $ Str x

parseBool :: Parser Expr
parseBool = do
  x <- oneOf "TF"
  y <- many1 letter
  let bool = [x] ++ y
  return . Bool $ case bool of
                    "True" -> True
                    "False" -> False

parseQtd :: Parser Expr
parseQtd = do
  char '\''
  x <- parseExpr
  return $ List [Sym "quote", x]

parseList :: Parser Expr
parseList = fmap List $ sepBy parseExpr space

parseExpr :: Parser Expr
parseExpr =
  parseNum <|>
  parseStr <|>
  parseBool <|>
  parseQtd <|>
  parseSym <|>
  do char '('
     x <- parseList
     char ')'
     return x

Main.hs:56:46:
Couldn't match expected type Expr' with actual typeIORef Expr'
Expected type: [(String, IORef Expr)] -> Maybe Expr
Actual type: [(String, IORef Expr)] -> Maybe (IORef Expr)
In the return type of a call of lookup' In the second argument of(.)', namely `lookup x'

Main.hs:60:8:
Couldn't match expected type ErrorT Err IO t0' with actual typeIO (Maybe Expr)'
In the return type of a call of `lookupEnv'
In a stmt of a 'do' block: x <- lookupEnv env var
In the expression:
do { x <- lookupEnv env var;
y <- readIORef env;
z <- newIORef exp;
writeIORef y ((var, z) : env);
.... }

Main.hs:80:10:
Couldn't match expected type ErrorT Err IO t0' with actual typeIO (Maybe Expr)'
In the return type of a call of `lookupEnv'
In a stmt of a 'do' block: res <- lookupEnv env x
In the expression:
do { res <- lookupEnv env x;
case res of {
Just _ -> return $ Sym x
Nothing -> throwError $ NotInScope x } }

Main.hs:103:13:
Couldn't match expected type ErrorT Err IO a0' with actual typeIO Env'
In the return type of a call of bind' In the first argument of(>>=)', namely
`bind env (zip params args)'
In the expression: bind env (zip params args) >>= flip eval form
Failed, modules loaded: none.