public
Created

Minimal Lisp in Haskell

  • Download Gist
lisp.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74
{-# 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)]

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.