Improve code

app/Assembler/Emitter.hs

@@ -10,10 +10,12 @@ import Data.Word (Word8)
 import qualified Data.Map as M
 
 import Assembler.Parser (AST(..), Scope(..))
+import Data.Functor ((<&>))
+import Util (maybeToExcept, maybeToEither)
 
 
-data Bean = Byte Word8
+data Bean = Byte      { _byte      :: Word8  }
-          | Reference String
+          | Reference { _reference :: String }
           deriving (Show, Eq)
 
 data Context = Context { _beans        :: [Bean]
@@ -29,7 +31,6 @@ emitBean :: Bean -> ExceptT String (State Context) ()
 emitBean bean = lift $ do
   ctx <- get
   put ctx { _beans = _beans ctx ++ [bean] }
-  return ()
 
 emitByte :: Word8 -> ExceptT String (State Context) ()
 emitByte byte = emitBean $ Byte byte
@@ -39,9 +40,7 @@ emitParam (Param (Integer x))  = emitByte $ fromIntegral x
 emitParam (Param (LabelRef Global l)) = emitBean $ Reference l
 emitParam (Param (LabelRef Local l)) = do
   ctx <- lift get
-  scope <- case _currentLabel ctx of
+  scope <- maybeToExcept (_currentLabel ctx) $ "Local label ('." ++ l ++ "') reference is allowed only in the global label scope"
-    (Just s) -> return s
-    Nothing  -> throwError $ "Local label ('." ++ l ++ "') reference is allowed only in the global label scope"
   emitBean $ Reference (scope ++ "." ++ l)
 emitParam _ = throwError "Number or label reference expected"
 
@@ -52,31 +51,25 @@ emitLabelDef (LabelDef Global label) = do
   let current = length (_beans ctx)
   when (label `M.member` labels) (throwError $ "Label '" ++ label ++ "' is already defined")
   put ctx { _labels = M.insert label current labels, _currentLabel = Just label }
-  return ()
 emitLabelDef (LabelDef Local label) = do
   ctx <- lift get
   let labels = _labels ctx
-  scope <- case _currentLabel ctx of
+  scope <- maybeToExcept (_currentLabel ctx) $ "Local label ('." ++ label ++ "') can be defined only in the global label scope"
-    (Just s) -> return s
-    Nothing  -> throwError $ "Local label ('." ++ label ++ "') can be defined only in the global label scope"
   let canonicalLabel = scope ++ "." ++ label
   let current = length (_beans ctx)
   when (canonicalLabel `M.member` labels) (throwError $ "Label '" ++ label ++ "' is already defined in the global label '" ++ scope ++ "' scope")
   put ctx { _labels = M.insert canonicalLabel current labels }
-  return ()
 emitLabelDef _ = throwError "Label definition expected"
 
 emitInstr :: Emitter
 emitInstr (Instruction (Operator op) Empty) = emitByte $ fromIntegral . fromEnum $ op
-emitInstr (Instruction (Operator op) (Params params)) = do
+emitInstr (Instruction (Operator op) (Params params)) = emitByte (fromIntegral $ fromEnum op) >> mapM_ emitParam params
-  emitByte $ fromIntegral $ fromEnum op
-  mapM_ emitParam params
 emitInstr _ = throwError "Instruction expected"
 
 emitLine :: Emitter
 emitLine (Line labelDef Empty) = emitLabelDef labelDef
 emitLine (Line Empty instr) = emitInstr instr
-emitLine (Line labelDef instr) = emitLabelDef labelDef >> emitInstr instr >> return ()
+emitLine (Line labelDef instr) = emitLabelDef labelDef >> emitInstr instr
 emitLine _ = throwError "Line of code expected"
 
 emitProgram :: Emitter
@@ -85,21 +78,14 @@ emitProgram _ = throwError "Program code expected"
 
 resolveLabels :: M.Map String Int -> [Bean] -> Either String [Bean]
 resolveLabels labels beans = sequence $ foldr folder [] beans
-  where
+  where folder b acc = resolveLabel labels b : acc
-    folder b acc = resolveLabel labels b : acc
 
 resolveLabel :: M.Map String Int -> Bean -> Either String Bean
 resolveLabel _ b@(Byte _) = Right b
-resolveLabel labels (Reference label) = case M.lookup label labels of
+resolveLabel labels (Reference label) = Byte . fromIntegral <$> maybeToEither (M.lookup label labels) ("Label '" ++ label ++ "' is not defined")
-    (Just t) -> Right . Byte . fromIntegral $ t
+
-    Nothing  -> Left $ "Label '" ++ label ++ "' is not defined"
 
 emit :: AST -> Either String [Word8]
-emit root = do
+emit root = evalState (runExceptT $ emitProgram root >> lift get) empty >>= \ctx -> resolveLabels (_labels ctx) (_beans ctx) <&> map _byte
-  ctx <- flip evalState empty $ runExceptT $ emitProgram root >> lift get
-  let labels = _labels ctx
-  let beans = _beans ctx
-  resolved <- resolveLabels labels beans
-  return $ map (\(Byte b) -> b) resolved
 
   

app/Assembler/Parser.hs

@@ -6,7 +6,8 @@ import Data.Monoid (First(..))
 
 import qualified Assembler.Tokenizer as T (Token(..))
 import VirtualMachine.VM (Op)
-import Util (explode)
+import Util (explode, maybeToEither)
+import Control.Monad (guard)
 
 data Scope = Local | Global deriving (Eq, Show, Enum, Bounded)
 
@@ -27,7 +28,9 @@ data AST = Empty
          deriving (Eq, Show)
 
 type ConsumedTokens = Int
-data ParseResult = ParseResult AST ConsumedTokens deriving (Eq, Show)
+data ParseResult = ParseResult { _ast :: AST
+                               , _consumed :: ConsumedTokens
+                               } deriving (Eq, Show)
 
 type Parser = [T.Token] -> Maybe ParseResult
 
@@ -64,16 +67,14 @@ parseDot _         = Nothing
 -- label_def := '.'? ID ':'
 parseLabelDef :: Parser
 parseLabelDef = parseSeq [parseOptionally parseDot, parseIdentifier, parseColon] combine
-  where
+  where combine [Dot, Identifier iden, _] = LabelDef Local iden
-    combine [Dot, Identifier iden, _] = LabelDef Local iden
+        combine [_,   Identifier iden, _] = LabelDef Global iden
-    combine [_,   Identifier iden, _] = LabelDef Global iden
 
 -- label_ref := '&' ID
 parseLabelRef :: Parser
 parseLabelRef = parseSeq [parseAmpersand, parseOptionally parseDot, parseIdentifier] combine
-  where
+  where combine [_, Dot, Identifier iden] = LabelRef Local iden
-    combine [_, Dot, Identifier iden] = LabelRef Local iden
+        combine [_, _,   Identifier iden] = LabelRef Global iden
-    combine [_, _,   Identifier iden] = LabelRef Global iden
 
 -- param := INT | label_ref
 parseParam :: Parser
@@ -89,9 +90,7 @@ parseLine = parseSeq [parseOptionally parseLabelDef, parseOptionally parseInstr]
 
 mapAST :: Parser -> (AST -> AST) -> Parser
 mapAST _ _ [] = Nothing
-mapAST parser mapper tokens = do
+mapAST parser mapper tokens = parser tokens >>= \(ParseResult ast consumed) -> return $ ParseResult (mapper ast) consumed
-  (ParseResult ast consumed) <- parser tokens
-  return $ ParseResult (mapper ast) consumed
 
 -- a?
 parseOptionally :: Parser -> Parser
@@ -105,14 +104,11 @@ parseMany0 parser combiner = parseOptionally $ parseMany parser combiner
 
 -- a+
 parseMany :: Parser -> ([AST] -> AST) -> Parser
-parseMany parser combiner tokens = if null asts
+parseMany parser combiner tokens = guard (not $ null asts) >> return (ParseResult ast consumed)
-  then Nothing
+  where results  = parseGreedy parser tokens
-  else Just $ ParseResult ast consumed
+        consumed = sum $ map _consumed results
-  where
+        asts     = map _ast results
-    results = parseGreedy parser tokens
+        ast      = combiner asts
-    consumed = sum $ map (\(ParseResult _ c) -> c) results
-    asts = map (\(ParseResult a _) -> a) results
-    ast = combiner asts
 
 -- a a a a a a a...
 parseGreedy :: Parser -> [T.Token] -> [ParseResult]
@@ -136,11 +132,10 @@ parseSeq :: [Parser] -> ([AST] -> AST) -> Parser
 parseSeq _ _ [] = Nothing
 parseSeq parsers combiner tokens = do
   results <- parseAll parsers tokens
-  let consumed = sum $ map (\(ParseResult _ c) -> c) results
+  let consumed = sum $ map _consumed results
-  let asts = map (\(ParseResult a _) -> a) results
+  let asts = map _ast results
-  if length asts == length parsers
+  guard $ length asts == length parsers
-  then return $ ParseResult (combiner asts) consumed
+  return $ ParseResult (combiner asts) consumed
-  else Nothing
 
 -- a b c
 parseAll :: [Parser] -> [T.Token] -> Maybe [ParseResult]
@@ -153,11 +148,7 @@ parseAll (p:ps) tokens = do
 -- 'Nothing' if not consumed tokens exist
 assertConsumed :: Parser -> Parser
 assertConsumed _ [] = Nothing
-assertConsumed parser tokens = do
+assertConsumed parser tokens = parser tokens >>= \r@(ParseResult _ consumed) -> guard (null $ drop consumed tokens) >> return r
-  r@(ParseResult _ consumed) <- parser tokens
-  if null (drop consumed tokens)
-  then return r
-  else Nothing
 
 parse :: [T.Token] -> Either String AST
 parse tokens = do
@@ -165,6 +156,4 @@ parse tokens = do
   let results = map (assertConsumed parseLine) codeLines
   let errors = filter ((==Nothing) . snd) $ zip codeLines results
   let errorMsg = "Parse error(s):\n" ++ intercalate "\n" (map (show . fst) errors)
-  case sequenceA results of
+  Program . map _ast <$> maybeToEither (sequenceA results) errorMsg
-    (Just r) -> return $ Program $ map (\(ParseResult ast _) -> ast) r
-    Nothing  -> Left errorMsg

app/Assembler/Tokenizer.hs

@@ -5,7 +5,8 @@ import Data.Char (ord, isDigit, isSpace, isAlpha, isAlphaNum, isHexDigit)
 import Data.Monoid (First(..))
 
 import VirtualMachine.VM (Op(..))
-import Util (toLowerCase, controlChar, unescape)
+import Util (toLowerCase, controlChar, unescape, maybeToEither)
+import Control.Monad (guard)
 
 
 data Token = Operator Op
@@ -28,14 +29,10 @@ type Tokenizer = String -> Maybe TokenizeResult
 type CaseSensitive = Bool
 keywordTokenizer :: CaseSensitive -> String -> Token -> Tokenizer
 keywordTokenizer _ _ _ [] = Nothing
-keywordTokenizer cs kwd token input
+keywordTokenizer cs kwd token input = guard matches >> return (TokenizeResult token len)
-  | matches    = Just $ TokenizeResult token len
+  where len     = length kwd
-  | otherwise  = Nothing
+        matches = mapper kwd == mapper (take len input)
-  where
+        mapper  = if cs then id else toLowerCase
-    len = length kwd
-    mapper = if cs then id else toLowerCase
-    zipped = zipWith (==) (mapper kwd) (mapper . take len $ input)
-    matches = and zipped && len == length zipped
 
 operatorTokenizer :: Op -> Tokenizer
 operatorTokenizer op = keywordTokenizer False (toLowerCase . show $ op) (Operator op)
@@ -46,37 +43,29 @@ tokenizeOperators = anyTokenizer $ map operatorTokenizer $ sortBy cmp [Nop ..]
 
 tokenizeIdentifier :: Tokenizer
 tokenizeIdentifier [] = Nothing
-tokenizeIdentifier input@(x:_) = if null identifier || (not . isAlpha) x
+tokenizeIdentifier input@(x:_) = guard (not $ null identifier) >> guard (isAlpha x) >> return token
-  then Nothing
-  else Just $ TokenizeResult (Identifier identifier) (length identifier)
   where identifier = takeWhile (or . sequenceA [isAlphaNum, (=='_')]) input
+        token      = TokenizeResult (Identifier identifier) (length identifier)
 
 tokenizeWhitespace :: Tokenizer
 tokenizeWhitespace [] = Nothing
-tokenizeWhitespace (x:_)
+tokenizeWhitespace (x:_) = guard (isSpace x) >> return (TokenizeResult WhiteSpace 1)
-  | isSpace x = Just $ TokenizeResult WhiteSpace 1
-  | otherwise = Nothing
 
 tokenizeDecimal :: Tokenizer
 tokenizeDecimal [] = Nothing
-tokenizeDecimal input = if null numberStr
+tokenizeDecimal input = guard (not $ null numberStr) >> return token
-  then Nothing
+  where numberStr = takeWhile isDigit input
-  else Just $ TokenizeResult (IntLiteral number) len
+        token     = TokenizeResult (IntLiteral $ read numberStr) $ length numberStr
-  where
-    number = read numberStr
-    len = length numberStr
-    numberStr = takeWhile isDigit input
 
 tokenizeHex :: Tokenizer
-tokenizeHex ('0':'x':input) = if null input
+tokenizeHex ('0':'x':input) = guard (not $ null numberStr) >> return token
-  then Nothing
-  else Just $ TokenizeResult (IntLiteral $ read $ "0x" ++ numberStr) (length numberStr + 2)
   where numberStr = takeWhile isHexDigit input
+        token     = TokenizeResult (IntLiteral $ read $ "0x" ++ numberStr) (length numberStr + 2)
 tokenizeHex _ = Nothing
 
 tokenizeChar :: Tokenizer
-tokenizeChar ('\'':'\\':x:'\'':_) = controlChar x >>= (\s -> return $ TokenizeResult (IntLiteral s) 4)
+tokenizeChar ('\'':'\\':x:'\'':_) = controlChar x >>= \s -> return $ TokenizeResult (IntLiteral s) 4
-tokenizeChar ('\'':x:'\'':_) = Just $ TokenizeResult (IntLiteral . ord $ x) 3
+tokenizeChar ('\'':x:'\'':_) = return $ TokenizeResult (IntLiteral . ord $ x) 3
 tokenizeChar _ = Nothing
 
 tokenizeString :: Tokenizer
@@ -89,11 +78,11 @@ tokenizeString ('"':xs) = do
     extractString (y:ys)
         | y == '"'  = Just []
         | y == '\n' = Nothing
-        | otherwise = extractString ys >>= (\r -> return $ y : r)
+        | otherwise = (y:) <$> extractString ys
 tokenizeString _  = Nothing
 
 tokenizeComment :: Tokenizer
-tokenizeComment (';':xs) = Just $ TokenizeResult (Comment comment) (length comment + 1)
+tokenizeComment (';':xs) = return $ TokenizeResult (Comment comment) (length comment + 1)
   where comment = takeWhile (/='\n') xs
 tokenizeComment _ = Nothing
 
@@ -103,9 +92,8 @@ sepTokenizer _ _ [] = Nothing
 sepTokenizer predicate tokenizer input = do
   result@(TokenizeResult _ consumed) <- tokenizer input
   let next = drop consumed input
-  if null next || (predicate . head $ next)
+  guard $ null next || (predicate . head $ next)
-  then return result
+  return result
-  else Nothing
 
 anyTokenizer :: [Tokenizer] -> Tokenizer
 anyTokenizer _ [] = Nothing
@@ -113,27 +101,24 @@ anyTokenizer tokenizers input = getFirst . mconcat . map First $ sequenceA token
 
 tokenize :: String -> Either String [Token]
 tokenize [] = Right []
-tokenize input = tokens >>= (Right . filter tokenFilter)
+tokenize input = tokens >>= (\(TokenizeResult token chars) -> (token:) <$> tokenize (drop chars input)) >>= (Right . filter tokenFilter)
-  where
+  where tokens = maybeToEither (tokenizers input) $ "Unknown token: " ++ take 20 input
-    tokens = case tokenizers input of
+        tokenizers = anyTokenizer
-      (Just (TokenizeResult token chars)) -> tokenize (drop chars input) >>= (\rest -> return $ token : rest)
+         [ keywordTokenizer False "\n" NewLine
-      Nothing                             -> Left $ "Unknown token: " ++ take 20 input
+         , tokenizeWhitespace
-    tokenizers = anyTokenizer
+         , tokenizeComment
-      [ keywordTokenizer False "\n" NewLine
+         , sepTokenizer isSpace tokenizeOperators
-      , tokenizeWhitespace
+         , sepTokenizer isSpace tokenizeHex
-      , tokenizeComment
+         , sepTokenizer isSpace tokenizeDecimal
-      , sepTokenizer isSpace tokenizeOperators
+         , tokenizeIdentifier
-      , sepTokenizer isSpace tokenizeHex
+         , keywordTokenizer False ":" Colon
-      , sepTokenizer isSpace tokenizeDecimal
+         , keywordTokenizer False "&" Ampersand
-      , tokenizeIdentifier
+         , keywordTokenizer False "." Dot
-      , keywordTokenizer False ":" Colon
+         , tokenizeChar
-      , keywordTokenizer False "&" Ampersand
+         , tokenizeString
-      , keywordTokenizer False "." Dot
+         ]
-      , tokenizeChar
-      , tokenizeString
-      ]
 
 tokenFilter :: Token -> Bool
-tokenFilter WhiteSpace = False
+tokenFilter WhiteSpace  = False
-tokenFilter (Comment _)  = False
+tokenFilter (Comment _) = False
-tokenFilter _            = True
+tokenFilter _           = True

app/Main.hs

@@ -10,6 +10,5 @@ main = do
   input <- readFile filename
   result <- run input
   case result of
-    (Right vm) -> do
+    (Right vm) -> putStrLn $ "\n\nDone. \n" ++ show vm
-      putStrLn $ "\nDone\n" ++ show vm
     (Left err) -> putStrLn $ "\n\nError:\n" ++ err

app/Util.hs

@@ -5,13 +5,16 @@ module Util (
   head,
   unescape,
   controlChar,
-  explode
+  explode,
+  maybeToExcept,
+  maybeToEither
 ) where
 
 import Prelude hiding (head)
 import Data.Word (Word8)
 import Data.Char (chr, toLower)
 import Numeric (showHex)
+import Control.Monad.Except (MonadError (throwError))
 
 
 toLowerCase :: String -> String
@@ -25,10 +28,9 @@ byteStr = pad '0' 2 . flip showHex "" . (fromIntegral :: Word8 -> Integer)
 
 insertAtN :: a -> Int -> [a] -> [a]
 insertAtN c n xs = insertAtN' n xs
-  where
+  where insertAtN' 0 ys = c : insertAtN' n ys
-    insertAtN' 0 ys = c : insertAtN' n ys
+        insertAtN' _ [] = []
-    insertAtN' _ [] = []
+        insertAtN' m (y:ys) = y : insertAtN' (m-1) ys
-    insertAtN' m (y:ys) = y : insertAtN' (m-1) ys
 
 pad :: Char -> Int -> String -> String
 pad char width string = replicate (width - length string) char ++ string
@@ -38,11 +40,8 @@ head []    = Nothing
 head (x:_) = Just x
 
 unescape :: String -> Maybe String
-unescape ('\\':x:xs) = do
+unescape ('\\':x:xs) = (:) . chr <$> controlChar x <*> unescape xs
-  cc <- chr <$> controlChar x
+unescape (x:xs) = (x:) <$> unescape xs
-  rest <- unescape xs
-  return $ cc : rest
-unescape (x:xs) = unescape xs >>= (\rest -> return $ x : rest)
 unescape [] = Just []
 
 controlChar :: Char -> Maybe Int
@@ -62,8 +61,17 @@ controlChar x = case x of
 
 explode :: (Foldable f) => (a -> Bool) -> f a -> [[a]]
 explode predicate xs = filter (not . null) $ foldr split [[]] xs
-  where
+  where split _ [] = []
-    split _ [] = []
+        split y (ys:yss)
-    split y (ys:yss)
+          | predicate y = []:ys:yss
-      | predicate y = []:ys:yss
+          | otherwise   = (y:ys):yss
-      | otherwise   = (y:ys):yss 
+
+maybeToEither :: Maybe a -> e -> Either e a
+maybeToEither m err = case m of
+  (Just x) -> Right x
+  Nothing  -> Left err
+
+maybeToExcept :: MonadError e m => Maybe a -> e -> m a
+maybeToExcept m err = case m of
+  (Just x) -> return x
+  Nothing  -> throwError err

app/VirtualMachine/Interpreter.hs

@@ -13,14 +13,13 @@ import qualified Data.ByteString as B
 
 import VirtualMachine.VM (VM(..), Op, Computation, get, pop, pushS, forward, getPc, isHalted, isDebug)
 import VirtualMachine.Instruction (Instruction(..), Unit(..), instructionByOp)
+import Util (maybeToEither)
 
 
 parseInstr :: [Word8] -> Either String (Instruction, [Word8])
 parseInstr (opCode:rest) = do
   let op = toEnum . fromIntegral $ opCode :: Op
-  instr <- case M.lookup op instructionByOp of
+  instr <- maybeToEither (M.lookup  op instructionByOp) "Unknown instruction"
-    (Just i) -> Right i
-    Nothing -> Left "Unknown instruction"
   let noParams = _noParams instr
   let params = map fromIntegral $ take noParams rest :: [Word8]
   unless (length params == noParams) (Left $ "Expected " ++ show noParams ++ " parameter(s), got " ++ show (length params) ++ " for operator '" ++ show op ++ "'")

app/VirtualMachine/VM.hs

@@ -10,6 +10,7 @@ import qualified Data.Sequence as S
 import qualified Control.Monad.State as ST (get, put)
 import Data.Functor ((<&>))
 import Control.Monad (unless)
+import Util (maybeToExcept)
 
 
 data VM = VM { _pc    :: Int
@@ -85,9 +86,7 @@ isDebug :: Computation Bool
 isDebug = get <&> _debug
 
 stackAt :: Int -> String -> Computation Int
-stackAt index err = get >>= \vm -> case _stack vm S.!? index of
+stackAt index err = get >>= \vm -> maybeToExcept (_stack vm S.!? index) err
-  (Just i) -> return i
-  Nothing  -> throwError err
 
 frameAt :: Int -> (Int -> Int) -> String -> Computation Int
 frameAt index t name = do
@@ -95,9 +94,7 @@ frameAt index t name = do
   fp <- getFp
   unless (fp > -1) (throwError "No active stack frame")
   stackSize <- getStackSize
-  case _stack vm S.!? (stackSize - fp - 1 - t index) of
+  maybeToExcept (_stack vm S.!? (stackSize - fp - 1 - t index)) $ "Cannot determine " ++ name ++ " - index " ++ show index ++ " out of frame bounds"
-    (Just i) -> return i
-    Nothing  -> throwError $ "Cannot determine " ++ name ++ " - index " ++ show index ++ " out of frame bounds"
 
 updateFrameAt :: Int -> Int -> Computation ()
 updateFrameAt index value = do