[Haskell-cafe] Minim interpreter

[Chaddaï Fouché]

I wrote such an interpreter though the code is quite ugly due to my
lack of experience in the field as well as with Haskell... It took me
the better part of two hour but mainly because I didn't use Parsec
before this. I would of course be happy of any suggestion to amend it
but a plain rewriting might be best... (even by me ;-) )
There are probably some bugs (in part due to the fuzzy definition of
the language semantics and real syntax).
Here is the beast :
module Minim (the real work is done here)
##############################################
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
    | Ge 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 =
    s0 `seq`
    case s0 of
      Assign str expr -> evalS ss tags
                         $ M.insert str (evalE expr context) context
      Inc str -> evalS ss tags
                 $ M.adjust inc_expr str 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.adjust dec_expr str 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
      Ge 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
##############################################
module MinimParser (parseFile) where
import Minim
import Text.ParserCombinators.Parsec hiding (spaces, parseTest)
import Text.ParserCombinators.Parsec.Expr
import Text.ParserCombinators.Parsec.Token hiding (symbol)
import Control.Monad

spaces :: Parser ()
spaces = skipMany1 $ char ' '

symbol :: Parser String
symbol = many1 letter

litVar :: Parser Expr
litVar = liftM EVar symbol

litString :: Parser Expr
litString = do char '"'
               s <- many (noneOf "\"")
               char '"'
               return $ Str s

litNumber :: Parser Expr
litNumber = return . Number . read =<< many digit

parseExpr :: Parser Expr
parseExpr = litVar <|> litString <|> litNumber

opTable = [ [Infix (string "and" >> return And) AssocNone,
             Infix (string "or" >> return Or) AssocNone],
            [Prefix (string "not" >> return Not)]
          ]

parseTest :: Parser Test
parseTest = buildExpressionParser opTable simpleTest

simpleTest :: Parser Test
simpleTest =
    (do char '('
        spaces
        test <- parseTest
        spaces
        char ')'
        return test
    ) <|>
    do e1 <- parseExpr
       spaces
       op <- oneOf "=<>"
       spaces
       e2 <- parseExpr
       return $ case op of
                  '=' -> Eq e1 e2
                  '<' -> Le e1 e2
                  '>' -> Ge e1 e2

printS :: Parser Statement
printS =
    do
      string "print"
      spaces
      expr <- parseExpr
      return $ Print expr

inputS :: Parser Statement
inputS =
    do
      string "input"
      spaces
      var <- symbol
      return $ Input var

assignS :: Parser Statement
assignS =
    do
      var <- symbol
      spaces
      string "is"
      spaces
      expr <- parseExpr
      return $ Assign var expr

gotoS :: Parser Statement
gotoS = liftM Goto $ string "goto" >> spaces >> symbol

incS :: Parser Statement
incS = liftM Inc $ string "++" >> spaces >> symbol

decS :: Parser Statement
decS = liftM Dec $ string "--" >> spaces >> symbol

condS :: Parser Statement
condS =
    do
      string "if"
      spaces
      test <- parseTest
      spaces
      string "then"
      spaces
      s1 <- parseStatement
      spaces
      string "else"
      spaces
      s2 <- parseStatement
      return $ Cond test s1 s2

parseStatement :: Parser Statement
parseStatement =
    incS <|>
    decS <|>
    printS <|>
    try condS <|>
    inputS <|>
    gotoS <|>
    (string "nl" >> return Nl) <|>
    assignS

parseProgram :: Parser Program
parseProgram =
    try (do
          stat <- parseStatement
          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
##############################################
main module (nothing there of course)
##############################################
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
##############################################

-- 
Jedaï