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 whereimport Control.Applicative ((<$>), (<$), (<*>), (<*))import Control.Categoryimport Control.Monad.Errorimport Control.Monad.IO.Classimport Control.Monad.State.Strictimport Data.Bitsimport Data.Char (chr,ord)import Data.IntMap.Strict as IM hiding (null)import Data.Lensimport Data.Lens.Templateimport Data.Map.Strict as M hiding (null)import Data.Maybeimport Prelude hiding ((.))import Text.Parsec hiding (label)import Text.Parsec.Char----------------- Utility code(??) t _ True  = t(??) _ f False = fio = liftIOa !!= b = (a != b) >> return ()-- Lens for array itemsitem :: Integer -> Lens (IntMap v) vitem idx = lens (IM.! (fromInteger idx)) (IM.insert (fromInteger idx))------------ PARSINGtype ProgPtr = [Tok]data Tok = Label String         | Number Integer         | Keyword String            deriving Showcomment = (string /* >> in_comment) <?> commentvoidChar = () <$ anyCharin_comment =  (try (string */) >> return ())          <|> ((comment <|> voidChar) >> in_comment)           <?> end of commentwhitespace = 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 parsingprogram = optional whitespace >> (tok `sepEndBy1` whitespace) <* eof-------------- Compiling-- find all labels, will use them as variables laterallLabels = M.fromList . allLabels' where        allLabels' [] = []        allLabels' (Label l : xs) = (l, PtrVal xs) : allLabels' xs        allLabels' (_ : xs) = allLabels' xs-------------- Executiondata 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 vinstance 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) ainitProg p = ProgState    []               -- empty stack at startup    (allLabels p)    -- first convert all labels as pointer variables     IM.empty            -- empty array    p                -- full program as initial IPexit = (ip !!= [])dump :: MangoT IO ()dump = (get >>= io.print)crash reason = (io.print) reason >> dump >> exitm <!> 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 intpopp = do { (_, PtrVal p) <- pop; return p } <!> Cannot pop required ptrpops = do { (Just s, _) <- pop; return s } <!> Cannot pop symbolbinop 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 operandexec (Label _)  = return () exec (Number n) = pushi nexec (Keyword add) = binop (+)exec (Keyword call) = do        tgt <- popp        cur <- access ip        push (Nothing, PtrVal cur)        ip !!= tgtexec (Keyword dup) = do { x <- pop; push x; push x }exec (Keyword exit) = exitexec (Keyword ifz) = cjump (== 0)exec (Keyword ifg) = cjump (> 0)exec (Keyword jump) = popp >>= (ip !!=)exec (Keyword mod) = binop modexec (Keyword print_byte) = popi >>= io.putChar.chr.fromIntegerexec (Keyword print_num) = popi >>= io.putStr.showexec (Keyword read_num) = io readLn >>= pushiexec (Keyword read_byte) = io getChar >>= pushi.toInteger.ordexec (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) !!= xexec (Keyword xor) = binop xorexec (Keyword k) = do        vs <- access vars        push (Just k, fromMaybe (IntVal 0) (M.lookup k vs))fetch = ip !%%= uconsstep = catchError (fetch >>= exec) crashdumpLens l = access l >>= (io . print)terminated = null <$> access iploop step = step >> (terminated >>= (return () ?? loop step))runProgWith step p = evalStateT (loop step) (initProg p)runProgram = runProgWith step onLeft _ (Right x) = Right xonLeft 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 errdecodeArgs [file]      = return (file, runProgram)decodeArgs [-d,file] = return (file, debugProgram)decodeArgs _           = fail Usage: hango [-d] file.mangomain = withErrors $ do        (file,run) <- io getArgs >>= decodeArgs        prog <- wrapError . ErrorT $ parseFromFile program file        run prog
A stack-based language interpreter in Haskell
haskell;interpreter