lisp.hs

module Main where

import Control.Monad.Error
import Text.ParserCombinators.Parsec

-- Types

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

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

instance Error Err

type ErrorOr = Either Err

-- Environment

type Env = [(String, Expr)]

nullEnv = [] :: Env
updateEnv env [] [] = env
updateEnv env (x:xs) (y:ys) = (x, y) : updateEnv env xs ys

-- Evaluation

eval :: Env -> Expr -> ErrorOr Expr
eval env (Sym x) = do
  let result = lookup x env
  case result 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 "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] -> ErrorOr Expr
apply (Func env params form) args =
  eval (updateEnv env params args) form >>= return
apply _ _ = return $ Str "hello"

-- 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 <- many1 letter
  return . Bool $ case x 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