Lisp処理系

適当なLisp処理系(と言えるのか？)を作りました。半日で作った感じなので、細かいミスは仕方ない！

import System.IO
import Control.Monad
import Text.ParserCombinators.Parsec

data LispVal = Atom    String
             | Boolean Bool
             | String  String
             | Number  Integer
             | List    [LispVal]
             | Proc    LispProc

instance Show LispVal where
    show (Atom    a) = a
    show (Boolean b) = if b then "#t" else "#f"
    show (String  s) = show s
    show (Number  n) = show n
    show (List    l) = "(" ++ (foldl1 (?a b-> a++" "++b) $ map show l) ++ ")"
    show (Proc    _) = "<function>"

type LispProc = [LispVal] -> LispVal
type Env = [(String, LispVal)]
type LParser = GenParser Char Env

fromAtom   (Atom   a) = a
fromNumber (Number x) = x
fromString (String s) = s
fromList   (List   l) = l

primitive :: [(String, LispVal)]
primitive =
    [ ("+", makeFun Number fromNumber (+))
    , ("-", makeFun Number fromNumber (-))
    , ("*", makeFun Number fromNumber (*))
    , ("/", makeFun Number fromNumber div)
    ]
    ++
    [ ("string-append", makeFun String fromString (++))
    ]
    ++
    [ ("number?", Proc $ ?l -> case head l of
                                 Number _ -> Boolean True
                                 _        -> Boolean False)
    ]
    ++
    [ ("list", Proc $ List)
    , ("car", Proc $ ?[x] -> head $ fromList x)
    , ("cdr", Proc $ ?[x] -> List $ tail $ fromList x)
    , ("append", makeFun List fromList (++))
    ]
    where makeFun dataCon from f = Proc $ dataCon . (foldl1 f) . (map from)

pStart :: LParser (LispVal, Env)
pStart = do result <- pLisp
            state  <- getState
            return (result, state)

pLisp :: LParser LispVal
pLisp = do v <-  try pDefine <|> try pLambda <|>
                 pLispExp <|> pLispNumber <|> pLispString <|>
                 pLispBoolean <|> pLispAtom
           spaces
           return v
pLispExp :: LParser LispVal
pLispExp = do (op:args) <- between (char '(') (char ')') $ many1 pLisp
              table <- getState
              case op of
                Proc p -> return $ p args
                _      -> fail $ "not function"

pLispNumber :: LParser LispVal
pLispNumber  = many1 digit >>= return . Number . read
pLispString  = between (char '"') (char '"') $ many1 (noneOf " ?"") >>= return . String
pLispBoolean = do char '#'
                  (char 't' >> return (Boolean True)) <|> (char 'f' >> return (Boolean False))
pLispAtom = do s     <- many1 (noneOf "() ?t?n'?"#")
               table <- getState
               case lookup s table of
                 Nothing -> fail $ "unbound variable: " ++ s
                 Just x  -> return x

pDefine :: LParser LispVal
pDefine = between (char '(') (char ')') inner
    where inner = do string "define"
                     spaces
                     name <- many1 $ noneOf "() ?t?n'?"#"
                     spaces
                     val  <- pLisp
                     updateState ((name,val):)
                     return $ Atom name
pLambda :: LParser LispVal
pLambda = between (char '(') (char ')') inner
    where inner = do string "lambda"
                     spaces
                     argNames <- between (char '(') (char ')') $ sepBy1 ident spaces
                     spaces
                     def   <- getExpr 0
                     table <- getState
                     return $ Proc $ ?args -> 
                         case eval (zip argNames args ++ table) def of
                           Left e -> String $ show (zip argNames args ++ table)
                           Right (v,_) -> v
ident = do f <- letter
           t <- many alphaNum
           return $ f:t
getExpr n = do a <- anyChar
               let m = case a of
                         '(' -> n+1
                         ')' -> n-1
                         _   -> n
               if a==')' && m==0 then return [a]
                                 else do rest <- getExpr m
                                         return $ a:rest

main :: IO ()
main = main' primitive
    where main' s = do putStr "mins> " >> hFlush stdout
                       expr <- getLine
                       case eval s expr of
                         Left  e     -> print e >> main' s
                         Right (v,s) -> print v >> main' s
eval s str = runParser pStart s "" str

うーん、バックスラッシュがはてなマークになってしまうな…。