Minimal Lisp in Haskell

lisp.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE LambdaCase #-}

import Control.Applicative
import Control.Monad.State.Strict
import Data.Function (on)
import Data.Foldable (foldrM)
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

type Context = [(B.ByteString, Value)]
data Value = Fun (Value -> State Context Value)
           | List [Value]
           | Number Integer
           | Symbol B.ByteString
           deriving (Show)
instance Show (Value -> State Context Value) where
  show _ = ""

eval (List []) = return (List [])
eval (List (x:xs)) = do Fun f <- eval x
                        f (List xs)
eval x@(Number _) = return x
eval (Symbol name) = gets $ fromJust . lookup name

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\\-")

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

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

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

car (List vs) = [ v' | [List (v':_)] <- subeval vs ]
cdr (List vs) = [ List vs' | [List (_:vs')] <- subeval vs]
cons (List vs) = [List (v':vs') |  [v', List vs'] <- subeval vs]
cond (List [c, t, f]) = (\case
                           List [] -> f
                           _       -> t) <$> eval c
def (List [Symbol ss, v]) = List [] <$ do v' <- eval v
                                          modify (unionContext [(ss, v')])

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

quote (List [x]) = return x

subeval = foldrM (\v vs' -> (:) <$> eval v <*> return vs') []

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