Here is a little interpreter I wrote for a simple stack-based language. It is my first attempt at a complete Haskell program, beyond glorified calculator use.
I'd like very much to get an expert's opinon on stylistic matters.
Also, although the thing runs fine, on a test program it seems to suffer from a space leak: I see an increasing amount of Map objects in Drag state, at one particular spot in the code (where the SCC "store1" directive is). I don't understand why the insert step would not free the old Map version. Also, retainer profiling blames the "arry" lens, which is not even used in this piece of code, and uses an IntMap, not a Map. I don't understand what is going on...
EDIT: whoops. I was using the sieve of Eratosthenes as a test program for my interpreter, so it is probably normal that the IntMap usage grows linearily in time..
{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE TemplateHaskell #-} module Mango where import Control.Applicative ((<$>), (<$), (<*>), (<*)) import Control.Category import Control.Monad.Error import Control.Monad.IO.Class import Control.Monad.State.Strict import Data.Bits import Data.Char (chr,ord) import Data.IntMap.Strict as IM hiding (null) import Data.Lens import Data.Lens.Template import Data.Map.Strict as M hiding (null) import Data.Maybe import Prelude hiding ((.)) import Text.Parsec hiding (label) import Text.Parsec.Char --------------- -- Utility code (??) t _ True = t (??) _ f False = f io = liftIO a !!= b = (a != b) >> return () -- Lens for array items item :: Integer -> Lens (IntMap v) v item idx = lens (IM.! (fromInteger idx)) (IM.insert (fromInteger idx)) ---------- -- PARSING type ProgPtr = [Tok] data Tok = Label String | Number Integer | Keyword String deriving Show comment = (string "/*" >> in_comment) <?> "comment" voidChar = () <$ anyChar in_comment = (try (string "*/") >> return ()) <|> ((comment <|> voidChar) >> in_comment) <?> "end of comment" whitespace = many1 (() <$ space <|> comment ) tchar = oneOf $ '_' : ['a'..'z'] tok = Number . read <$> many1 digit <|> do ident <- many1 tchar (char ':' >> return (Label ident)) <|> return (Keyword ident) <?> "token" -- eof here chokes on trailing garbage, but prevents single-pass parsing program = optional whitespace >> (tok `sepEndBy1` whitespace) <* eof ------------ -- Compiling -- find all labels, will use them as variables later allLabels = M.fromList . allLabels' where allLabels' [] = [] allLabels' (Label l : xs) = (l, PtrVal xs) : allLabels' xs allLabels' (_ : xs) = allLabels' xs ------------ -- Execution data Value = IntVal Integer | PtrVal ProgPtr {- Stack values contain both a value and an optional variable symbol. - This is to get around a language quirk, the "magical" semantics - of 'store' which operates on the name of the last variable pushed - instead of on its content. This seemed a more robust approach - than looking ahead for a 'store' token in the parser to distinguish - symbols from values. -} newtype Stack = Stack { unStack :: (Maybe String, Value) } instance Show Stack where show (Stack (Nothing, v)) = show v show (Stack (Just var, v)) = "<" ++ var ++ ">" ++ show v instance Show Value where show (IntVal n) = show n show (PtrVal _) = "<pointer>" data ProgState = ProgState { _stack :: [Stack], _vars :: Map String Value, _arry :: IntMap Value, _ip :: ProgPtr } deriving Show $( makeLenses [''ProgState] ) type MangoT m a = StateT ProgState (ErrorT String m) a initProg p = ProgState [] -- empty stack at startup (allLabels p) -- first convert all labels as pointer variables IM.empty -- empty array p -- full program as initial IP exit = (ip !!= []) dump :: MangoT IO () dump = (get >>= io.print) crash reason = (io.print) reason >> dump >> exit m <!> r = catchError m (const $ throwError r) push = (>> return ()) . (stack %=) . (:) . Stack pushi x = push (Nothing, IntVal x) ucons (h:t) = (h,t) pop = unStack <$> (stack !%%= ucons) popi = do { (_, IntVal v) <- pop; return v } <!> "Cannot pop required int" popp = do { (_, PtrVal p) <- pop; return p } <!> "Cannot pop required ptr" pops = do { (Just s, _) <- pop; return s } <!> "Cannot pop symbol" binop f = do { y <- popi; x <- popi; pushi (x `f` y) } cjump test = do no <- popp yes <- popp x <- popi if test x then ip !!= yes else ip !!= no -- Execution of a single operand exec (Label _) = return () exec (Number n) = pushi n exec (Keyword "add") = binop (+) exec (Keyword "call") = do tgt <- popp cur <- access ip push (Nothing, PtrVal cur) ip !!= tgt exec (Keyword "dup") = do { x <- pop; push x; push x } exec (Keyword "exit") = exit exec (Keyword "ifz") = cjump (== 0) exec (Keyword "ifg") = cjump (> 0) exec (Keyword "jump") = popp >>= (ip !!=) exec (Keyword "mod") = binop mod exec (Keyword "print_byte") = popi >>= io.putChar.chr.fromInteger exec (Keyword "print_num") = popi >>= io.putStr.show exec (Keyword "read_num") = io readLn >>= pushi exec (Keyword "read_byte") = io getChar >>= pushi.toInteger.ord exec (Keyword "store") = {-# SCC "store1" #-} do addr <- pops (_, n) <- pop vars !%= M.insert addr n return () exec (Keyword "sub") = binop (-) exec (Keyword "vload") = do i <- popi x <- access (item i . arry) push (Nothing,x) return () exec (Keyword "vstore") = do (_,x) <- pop idx <- popi (item idx . arry) !!= x exec (Keyword "xor") = binop xor exec (Keyword k) = do vs <- access vars push (Just k, fromMaybe (IntVal 0) (M.lookup k vs)) fetch = ip !%%= ucons step = catchError (fetch >>= exec) crash dumpLens l = access l >>= (io . print) terminated = null <$> access ip loop step = step >> (terminated >>= (return () ?? loop step)) runProgWith step p = evalStateT (loop step) (initProg p) runProgram = runProgWith step onLeft _ (Right x) = Right x onLeft f (Left x) = Left (f x) wrapError = mapErrorT (fmap (onLeft show)) withErrors m = do r <- runErrorT m case r of Right _ -> return () Left err -> fail err decodeArgs [file] = return (file, runProgram) decodeArgs ["-d",file] = return (file, debugProgram) decodeArgs _ = fail "Usage: hango [-d] file.mango" main = withErrors $ do (file,run) <- io getArgs >>= decodeArgs prog <- wrapError . ErrorT $ parseFromFile program file run prog 
