Create a gist now

Instantly share code, notes, and snippets.

@fogus /lisp.hs
Created Jan 29, 2012

Minimal Lisp in Haskell
{-# 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)]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment