There was more than "some" bugs, and a lack of strictness that led to
a stack overflow for high values of x... So here is a better version
(not quite there still, but better).
--
Jedaï
{-# OPTIONS -fbang-patterns -funbox-strict-fields #-}
module Minim (Statement (..), Test (..), Program (..), Expr (..), eval) where
import qualified Data.Map as M
import Data.Char
data Statement =
Assign String Expr
| Inc String
| Dec String
| Cond Test Statement Statement
| Goto String
| Print Expr
| Nl
| Input String
deriving (Show)
data Test =
Le Expr Expr
| Eq Expr Expr
| And Test Test
| Or Test Test
| Not Test
deriving (Show)
data Expr =
Str String
| Number !Int
| EVar String
deriving (Eq, Ord)
instance Show Expr where
show (Str s) = s
show (Number i) = show i
show (EVar s) = "Variable : " ++ s
newtype Program = Program ([Statement],[(String,[Statement])])
deriving (Show)
eval :: Program -> IO ()
eval (Program (xs, tags)) =
evalS xs tags M.empty
evalS :: [Statement] -> [(String, [Statement])] -> M.Map String Expr -> IO ()
evalS (s0:ss) tags !context =
case s0 of
Assign str expr -> evalS ss tags
$ M.insert str (evalE expr context) context
Inc str -> evalS ss tags $ M.insertWith' inc_expr str undefined context
where
inc_expr _ !(Number i) = Number $ i + 1
inc_expr _ _ = error $ "You can't increment "
++ str ++ ", it isn't numeric.\n"
Dec str -> evalS ss tags $ M.insertWith' dec_expr str undefined context
where
dec_expr _ !(Number i) = Number $ i - 1
dec_expr _ _ = error $ "You can't increment "
++ str ++ ", it isn't numeric.\n"
Cond test s1 s2 -> if evalT test context
then evalS (s1:ss) tags context
else evalS (s2:ss) tags context
Goto str -> maybe
(error $ "No such tag : " ++ str)
(\nss -> evalS nss tags context)
$ lookup str tags
Print expr -> do putStr (show $ evalE expr context)
evalS ss tags context
Nl -> do putStrLn ""
evalS ss tags context
Input str -> do input <- getLine
let expr = if (not $ null input) && all isDigit input
then Number $ read input
else Str input
evalS ss tags $ M.insert str expr context
evalS [] _ _ = return ()
evalE :: Expr -> M.Map String Expr -> Expr
evalE (EVar str) context = maybe
(error $ "There's no such variable : " ++ str)
id $ M.lookup str context
evalE e _ = e
evalT :: Test -> M.Map String Expr -> Bool
evalT t context = case t of
Eq e1 e2 -> evalE e1 context == evalE e2 context
Le e1 e2 -> evalE e1 context < evalE e2 context
And t1 t2 -> evalT t1 context && evalT t2 context
Or t1 t2 -> evalT t1 context || evalT t2 context
Not t1 -> not $ evalT t1 context
module MinimParser (parseFile) where
import Minim
import Text.ParserCombinators.Parsec hiding (spaces, parseTest, token)
import Text.ParserCombinators.Parsec.Expr
import Text.ParserCombinators.Parsec.Token hiding (symbol)
import Control.Monad
sp :: Parser ()
sp = skipMany $ char ' '
spaces :: Parser ()
spaces = skipMany1 $ char ' '
token :: Parser a -> Parser ()
token p = spaces >> p >> spaces
symbol :: Parser String
symbol = many1 letter
litVar :: Parser Expr
litVar = liftM EVar symbol
litString :: Parser Expr
litString = liftM Str $ between (char '"') (char '"') $ many (noneOf "\"")
litNumber :: Parser Expr
litNumber = return . Number . read =<< many digit
parseExpr :: Parser Expr
parseExpr = litVar <|> litString <|> litNumber
opTable = [ [infixOp "and" And AssocNone, infixOp "or" Or AssocNone],
[Prefix (string "not" >> spaces >> return Not)] ]
infixOp name op assoc =
Infix (try $ token (string name) >> return op) assoc
parseTest :: Parser Test
parseTest = buildExpressionParser opTable simpleTest
simpleTest :: Parser Test
simpleTest =
between (char '(' >> sp) (sp >> char ')') parseTest <|>
do e1 <- parseExpr
op <- between sp sp $ oneOf "=<>"
e2 <- parseExpr
return $ case op of
'=' -> Eq e1 e2
'<' -> Le e1 e2
'>' -> Le e2 e1
printS :: Parser Statement
printS = liftM Print $ string "print" >> spaces >> parseExpr
inputS :: Parser Statement
inputS = liftM Input $ string "input" >> spaces >> symbol
assignS :: Parser Statement
assignS = do
var <- symbol
token $ string "is"
expr <- parseExpr
return $ Assign var expr
gotoS :: Parser Statement
gotoS = liftM Goto $ string "goto" >> spaces >> symbol
incS :: Parser Statement
incS = liftM Inc $ string "++" >> sp >> symbol
decS :: Parser Statement
decS = liftM Dec $ string "--" >> sp >> symbol
condS :: Parser Statement
condS = do
string "if" >> spaces
test <- parseTest
token $ string "then"
s1 <- parseStatement
token $ string "else"
s2 <- parseStatement
return $ Cond test s1 s2
nlS :: Parser Statement
nlS = string "nl" >> return Nl
parseStatement :: Parser Statement
parseStatement =
try (incS <|> decS <|> printS <|> try condS <|> inputS <|> gotoS <|> nlS)
<|> assignS
comments :: Parser ()
comments = char '#' >> skipMany (noneOf "\n")
parseProgram :: Parser Program
parseProgram =
skipMany ((sp <|> comments) >> newline) >>
(try (do
stat <- parseStatement
sp >> newline
program <- parseProgram
case program of
Program (stats, tags) -> return $ Program (stat:stats, tags)
) <|>
(do tag <- symbol
newline
program <- parseProgram
case program of
Program (stats, tags) -> return $ Program (stats, (tag,stats):tags)
) <|> (eof >> ( return $ Program ([], []) ))
)
parseFile :: String -> IO Program
parseFile fileName = do
input <- readFile fileName
case (parse parseProgram fileName input) of
Left err -> error $ show err
Right p -> return p
module Main where
import MinimParser
import Minim (eval)
import System
import System.IO
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
arg <- getArgs
program <- parseFile $ arg!!0
eval program
_______________________________________________
Haskell-Cafe mailing list
Haskell-Cafe@haskell.org
http://www.haskell.org/mailman/listinfo/haskell-cafe
