Minimal Lisp in Haskell

lisp.hs

{-# LANGUAGE OverloadedStrings #-}

{- To Run:
   Load in ghci
   :set -XOverloadedStrings (for convenience)
   Execute repl expr -}

import Control.Applicative
import Control.Monad.State.Strict
import Data.Function
import Data.Attoparsec
import Data.Attoparsec.Char8 (char8, isDigit_w8, isSpace_w8)
import Data.Attoparsec.Combinator
import qualified Data.ByteString as B hiding (unpack)
import qualified Data.ByteString.Char8 as B
import Data.List
import Data.Maybe
import Debug.Trace

type Context = [(B.ByteString, Value)]
data Value = Fun (Value -> State Context Value)
           | List [Value]
           | Number Integer
           | Symbol B.ByteString

instance Show Value where
  show (Fun f) = "Fun"
  show (List xs) = "List " ++ show xs
  show (Number n) = "Number " ++ show n
  show (Symbol ss) = "Symbol " ++ show ss

repl bs = case parseOnly value bs of
            Left e -> error e
            Right v -> runState (eval v) defaultContext

value :: Parser Value
value =
      List <$> (char8 '(' *> sepBy value (takeWhile1 isSpace_w8) <* char8 ')')
  <|> Number . fst . fromJust . B.readInteger <$> takeWhile1 isDigit_w8
  <|> Symbol <$> takeWhile1 (inClass "A-Za-z\\-")

begin (List bs) = last <$> subeval bs

-- These would be shorter with the new Monad Comprehensions extension!
car (List vs) = do
    [List (v':_)] <- subeval vs
    return v'
cdr (List vs) = do
    [List (_:vs')] <- subeval vs
    return (List vs')
cons (List vs) = do
    [v', (List vs')] <- subeval vs
    return $ List (v':vs')
cond (List [c, t, f]) = do
    res <- eval c
    eval $ case res of
               List [] -> f
               _       -> t
def (List [Symbol ss, v]) = do
    -- Peculiar: why did the eval here feel free to throw away the new context?
    v' <- eval v
    modify (unionContext [(ss, v')])
    return $ List []

eval (List []) = return (List [])
eval (List (x:xs)) = do
    -- Peculiar: why did the eval here feel free to throw away the new context?
    Fun f <- eval x
    f (List xs)
eval x@(Number _) = return x
eval (Symbol name) = gets $ fromJust . lookup name

fun (List [List ns, b]) = return (Fun f)
  where
    nctx = zipWith (\(Symbol k) v -> (k, v)) ns
    f (List as) = do
        modify $ unionContext (nctx as)
        eval b

quote (List [x]) = return x

subeval vs = reverse <$> foldM step [] vs
  where
    step vs' v = do
      -- Peculiar: this should be equivalent to what was here before,
      -- but doesn't seem to make much sense!
      actx <- get
      v' <- eval v
      modify (`unionContext` actx)
      return (v' : vs')

unionContext = unionBy ((==) `on` fst)

defaultContext = [("begin", Fun begin), ("car", Fun car), ("cdr", Fun cdr),
                  ("cons", Fun cons), ("cond", Fun cond), ("def", Fun def),
                  ("eval", Fun eval), ("fun", Fun fun), ("t", Symbol "t"),
                  ("quote", Fun quote)]