lisp.hs

module Main where

import qualified Data.Map as M
import Control.Monad.Error

-- Types

data Expr = Sym String
          | Lst [Expr]
          | Num Int
          | Str String
          | Bol Bool
          | Fun Env [String] Expr
          | Prm String
          -- | Prm ([Expr] -> Lisp Expr)
  deriving (Eq, Ord, Show)

data Err = NotInScope String
         | TypeMismatch String
         | NumArgs Integer
         -- | Parser ParseError
         | Default String
instance Error Err
instance Show Err where
  show = showErr
showErr (NotInScope var) = "Not in scope: " ++ var
showErr (TypeMismatch typ) = "Expected type: " ++ typ
showErr (NumArgs exp) = "Expected " ++ show exp ++ "arguments"
-- showErr (Parser err) = "Parse error: " ++ show err

type Lisp = Either Err

-- Environment

type Env = [M.Map String Expr]

nullEnv = [M.empty] :: Env
extEnv xs = (M.empty) : xs
checkEnv x [] = Nothing
checkEnv x (y:ys) =
  if M.member x y then
    M.lookup x y
  else checkEnv x ys
addEnv x y (z:zs) = (M.insert x y z) : zs
updEnv [] [] env = env
updEnv (x:xs) (y:ys) env = addEnv x y (updEnv xs ys env)
updEnv _ _ _ = error "Crash in updEnv, report this to the author."

-- Primitives

{-
prms = [Map.fromList [("cons", Prm FIXME),
                      ("car", Prm FIXME),
                      ("cdr", Prm FIXME),
                      ("+", Prm FIXME),
                      ("-", Prm FIXME),
                      ("*", Prm FIXME),
                      ("/", Prm FIXME),
                      ("=", Prm FIXME)]]
-}

initialEnv = [M.fromList [ ("cons", Prm "cons")
                           , ("car", Prm "car")
                           , ("cdr", Prm "cdr")
                           , ("not", Prm "not")
                           , ("+", Prm "+")
                           , ("-", Prm "-")
                           , ("*", Prm "*")
                           , ("/", Prm "/")
                           , ("=", Prm "=")
                           ]]

-- Evaluation

eval :: Env -> Expr -> Lisp Expr
eval env (Sym x) =
  case checkEnv x env of
    Just x -> return x
    Nothing -> throwError $ NotInScope x
-- eval env (Lst [(Sym "fn"), params, body]) =
  -- return $ Fun env (map (\(Sym x) -> x) params) (Lst body)
eval env (Lst ((Sym "fn"):(Lst params):(Lst body):[])) = return $ Fun env (map (\(Sym x) -> x) params) (Lst body)
eval env (Lst [(Sym "if"), cond, consq, alt]) =
  case eval env cond of
    Bol True -> eval env consq
    Bol False -> eval env alt
    _ -> throwError $ TypeMismatch "bool"
eval env (Lst [(Sym "'"), cont]) = return cont
eval env (Lst (op:args)) = apply (eval env op) $ map (eval env) args
eval env x = return x

apply :: Expr -> [Expr] -> Lisp Expr
-- apply (Prm fun) args = fun args
apply (Fun env params body) args = eval (updEnv params args (extEnv env)) body
apply (Prm "cons") (a:(Lst d):[]) = return $ Lst (a:d)
apply (Prm "cons") (a:b:[]) = return $ Lst [a, b]
apply (Prm "cons") _ = throwError $ Default "invalid arguments to cons"
apply (Prm "car") ((Lst []):[]) = throwError $ Default "can't take the car of an empty list"
apply (Prm "car") ((Lst (a:_)):[]) = return a
apply (Prm "cdr") ((Lst []):[]) = error "can't take the cdr of an empty list"
apply (Prm "cdr") ((Lst (_:d)):[]) = return $ Lst d
apply (Prm "not") ((Lst []):[]) = return $ Num 1
apply (Prm "not") (_:[]) = return $ Lst []
apply (Prm "not") _ = error "too many args to not"
apply (Prm "+") (Num x:Num y:[]) = return $ Num (x + y)
apply (Prm "+") _ = error "invalid arguments to +"
apply (Prm "-") (Num x:[]) = return $ Num (- x)
apply (Prm "-") (Num x:Num y:[]) = return $ Num (x - y)
apply (Prm "-") _ = error "invalid arguments to -"
apply (Prm "*") (Num x:Num y:[]) = return $ Num (x * y)
apply (Prm "*") _ = error "invalid arguments to *"
apply (Prm "/") (Num x:Num 0:[]) = error "attempt to divide by 0"
apply (Prm "/") (Num x:Num y:[]) = return $ Num (x `div` y)
apply (Prm "/") _ = error "invalid arguments to /"
apply (Prm "=") (a:b:[]) = if a == b then return $ Num 1 else return $ Lst []
apply (Prm _) _ = throwError $ Default "unknown primitive"

Main.hs:85:6:
Couldn't match expected type Either Err Expr' with actual typeExpr'
In the pattern: Bol True
In a case alternative: (Bol True) -> eval env consq
In the expression:
case eval env cond of {
(Bol True) -> eval env consq
(Bol False) -> eval env alt
_ -> throwError $ TypeMismatch "bool" }
Failed, modules loaded: none.