Minimal Lisp in Haskell

lisp.hs

{-# LANGUAGE OverloadedStrings #-}

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

import Control.Applicative
import Data.Attoparsec hiding (Result)
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)]
type Result = (Context, Value)
data Value = Fun (Context -> Value -> Result)
           | 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 -> eval defaultContext v

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 ctx (List bs) = (ctx', last vs)
  where (ctx', vs) = subeval ctx bs
car ctx (List vs) = (ctx', v')
  where (ctx', [List (v':_)]) = subeval ctx vs
cdr ctx (List vs) = (ctx', List vs')
  where (ctx', [List (_:vs')]) = subeval ctx vs
cons ctx (List vs) = (ctx, List $ v':vs')
  where (ctx', [v', (List vs')]) = subeval ctx vs
cond ctx (List [c, t, f]) = case snd $ eval ctx c of
                              List [] -> eval ctx f
                              _       -> eval ctx t
def ctx (List [Symbol ss, v]) = (ctx', List [])
  where (_, v') = eval ctx v
        ctx' = unionBy (\x y->fst x == fst y) [(ss, v')] ctx
eval ctx (List []) = (ctx, List [])
eval ctx (List (x:xs)) = f ctx $ List xs
  where (_, Fun f) = eval ctx x
eval ctx x@(Number _) = (ctx, x)
eval ctx (Symbol xs) = (ctx, fromJust $ xs `lookup` ctx)
fun ctx (List [List ns, b]) = (ctx, Fun f)
  where f ctx (List as) = let nctx = zipWith (\(Symbol k) v->(k, v)) ns as
                              ctx' = unionBy (\x y->fst x == fst y) nctx ctx
                           in eval ctx' b
quote ctx (List [x]) = (ctx, x)

subeval ctx vs =
  foldl' (\(actx, vs') v-> let (ctx', v') = eval actx v
                            in (unionBy (\x y->fst x == fst y) ctx' actx, vs' ++ [v']))
         (ctx, []) vs

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)]