読者です 読者をやめる 読者になる 読者になる

はわわーっ

はわわわわっ

scheme処理系っぽいもの

haskell

やってみた。
簡単な計算とdefineとlambdaくらいならできてるっぽい。

module Main where

import Control.Monad.Identity
import Control.Monad.State
import Data.Maybe
import System.IO
import Text.Parsec
import Text.Parsec.String
import qualified Text.Parsec.Token as P


data SchemeValue = Atom String
                 | Integer Integer
                 | Boolean Bool
                 | List [SchemeValue]
                 | Proc [String] SchemeValue
                 deriving (Eq, Show)

type Env = [(String, SchemeValue)]


schemeDef :: P.LanguageDef ()
schemeDef = P.LanguageDef { P.commentStart = "",
                            P.commentEnd = "",
                            P.commentLine = ";",
                            P.nestedComments = False,
                            P.identStart = letter <|> oneOf symbol,
                            P.identLetter = alphaNum <|> oneOf symbol,
                            P.opStart = undefined,
                            P.opLetter = undefined,
                            P.reservedNames = [],
                            P.reservedOpNames = [],
                            P.caseSensitive = True }

symbol :: String
symbol = "!$%&*+-/:<=>?@^_~"

lexer :: P.TokenParser ()
lexer = P.makeTokenParser schemeDef

identifier :: Parser String
identifier = P.identifier lexer

integer :: Parser Integer
integer = P.integer lexer

whiteSpace :: Parser ()
whiteSpace = P.whiteSpace lexer

parens :: Parser a -> Parser a
parens = P.parens lexer


pScheme :: Parser SchemeValue
pScheme = do whiteSpace
             choice [pAtom, pInteger, pList]

pAtom :: Parser SchemeValue
pAtom = do x <- identifier
           return $ Atom x

pInteger :: Parser SchemeValue
pInteger = do n <- integer
              return $ Integer n

pList :: Parser SchemeValue
pList = do xs <- parens $ pScheme `sepEndBy` whiteSpace
           return $ List xs


eval :: SchemeValue -> StateT Env Identity SchemeValue
eval (Integer n) = return $ Integer n
eval (Atom s) = do env <- get
                   case lookup s env of
                     Just val -> return $ val
                     _ -> error $ "unknown symbol: " ++ s
eval (List (x:xs))
  | x == Atom "define" = do let [Atom s, expr] = xs
                            expr' <- eval expr
                            env <- get
                            put $ (s, expr') : env
                            return $ Atom s
  | x == Atom "lambda" = do let [List vars, expr] = xs
                            return $ Proc (map strFromAtom vars) expr
  | x == Atom "if" = do let [cond, conseq, alt] = xs
                        cond' <- eval cond
                        if cond' == Boolean True
                          then eval conseq
                          else eval alt
  | isPrimitive x = do let op = fromJust $ lookup (strFromAtom x) primitives
                       args <- mapM eval xs
                       return $ op args
  | otherwise = do proc <- eval x
                   case proc of
                     Proc vars expr -> do args <- mapM eval xs
                                          env <- get
                                          put $ zip vars args ++ env
                                          val <- eval expr
                                          put env
                                          return val
                     _ -> error $ "unknown procedure: " ++ show proc
eval x = error $ "unknown value: " ++ show x

strFromAtom :: SchemeValue -> String
strFromAtom = \(Atom s) -> s

isPrimitive :: SchemeValue -> Bool
isPrimitive (Atom s) = s `elem` map fst primitives
isPrimitive _ = False


primitives :: [(String, [SchemeValue] -> SchemeValue)]
primitives = [ ("+", Integer . foldl (+) 0 . map unpackInteger),
               ("*", Integer . foldl (*) 1 . map unpackInteger),
               ("-", Integer . foldl1 (-) . map unpackInteger),
               ("=", Boolean . numOpBool (==)),
               ("<", Boolean . numOpBool (<)),
               (">", Boolean . numOpBool (>)),
               ("<=", Boolean . numOpBool (<=)),
               (">=", Boolean . numOpBool (>=)) ]

unpackInteger :: SchemeValue -> Integer
unpackInteger (Integer n) = n
unpackInteger x = error $ "not integer: " ++ show x

numOpBool :: (Integer -> Integer -> Bool) -> [SchemeValue] -> Bool
numOpBool op args = let args' = map unpackInteger args in
                      and $ zipWith op args' $ drop 1 args'


runScheme :: String -> StateT Env Identity SchemeValue
runScheme s = case parse pScheme "" s of
                Left e -> error $ "parse error: " ++ show e
                Right x -> eval x

runRepl :: Env -> IO ()
runRepl env = do putStr ">>> "
                 hFlush stdout
                 s <- getLine
                 let (val, env') = runIdentity $ runStateT (runScheme s) env
                 putStrLn $ show val
                 runRepl env'


main :: IO ()
main = runRepl []
>>> (+ 1 2)
Integer 3
>>> ((lambda (x) (* x x)) 3)
Integer 9
>>> (define factorial (lambda (n) (if (= n 0) 1 (* n (factorial (- n 1))))))
Atom "factorial"
>>> (factorial 5)
Integer 120