bartek/mvm
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Refactor code

Browse Source
This commit is contained in:
Bartłomiej Przemysław Pluta
2021-11-18 17:20:27 +01:00
parent c656b8ca4e
commit 2c56582460
15 changed files with 454 additions and 659 deletions
Download Patch File Download Diff File Expand all files Collapse all files

7
README.md
View File

@@ -28,10 +28,9 @@ List of available instructions:
| ``0x16`` | ``IN`` | Read input from stdin | | ``0x16`` | ``IN`` | Read input from stdin |
| ``0x17`` | ``OUT`` | Put top stack value to stdout as char | | ``0x17`` | ``OUT`` | Put top stack value to stdout as char |
| ``0x18`` | ``CLR x`` | Wipe out ``x`` values before the top value from the stack | | ``0x18`` | ``CLR x`` | Wipe out ``x`` values before the top value from the stack |
| ``0x19`` | ``ROLL`` | Rotate the stack/stack frame | | ``0x19`` | ``OVER`` | Duplicate and push the second value from the top |
| ``0x1A`` | ``OVER`` | Duplicate and push the second value from the top | | ``0x1A`` | ``LDL x`` | Lift the ``x`` from the _fp_ variable to the top of the stack |
| ``0x1B`` | ``LDL x`` | Lift the ``x`` from the _fp_ variable to the top of the stack | | ``0x1B`` | ``STL x`` | Store the top stack value under the ``x`` from the _fp_ variable |
| ``0x1C`` | ``STL x`` | Store the top stack value under the ``x`` from the _fp_ variable |
## Example ## Example
### Example 1 ### Example 1

2
app/Assembler/Compiler.hs
View File

@@ -7,4 +7,4 @@ import Assembler.Parser (parse)
import Assembler.Emitter (emit) import Assembler.Emitter (emit)
compile :: String -> Either String [Word8] compile :: String -> Either String [Word8]
compile input = return input >>= tokenize >>= parse >>= emit compile input = tokenize input >>= parse >>= emit

35
app/Assembler/Emitter.hs
View File

@@ -12,18 +12,18 @@ import qualified Data.Map as M
import Assembler.Parser (AST(..), Scope(..)) import Assembler.Parser (AST(..), Scope(..))
data Bean = Byte Word8 data Bean = Byte Word8
| Reference String | Reference String
deriving (Show, Eq) deriving (Show, Eq)
data Context = Context { _beans :: [Bean] data Context = Context { _beans :: [Bean]
, _labels :: M.Map String Int , _labels :: M.Map String Int
, _currentLabel :: Maybe String , _currentLabel :: Maybe String
} deriving (Show, Eq) } deriving (Show, Eq)
type Emitter = AST -> ExceptT String (State Context) () type Emitter = AST -> ExceptT String (State Context) ()
empty :: Context empty :: Context
empty = Context { _beans = [], _labels = M.fromList [], _currentLabel = Nothing } empty = Context { _beans = [], _labels = M.empty, _currentLabel = Nothing }
emitBean :: Bean -> ExceptT String (State Context) () emitBean :: Bean -> ExceptT String (State Context) ()
emitBean bean = lift $ do emitBean bean = lift $ do
@@ -32,17 +32,17 @@ emitBean bean = lift $ do
return () return ()
emitByte :: Word8 -> ExceptT String (State Context) () emitByte :: Word8 -> ExceptT String (State Context) ()
emitByte byte = emitBean $ Byte $ byte emitByte byte = emitBean $ Byte byte
emitParam :: Emitter emitParam :: Emitter
emitParam (Param (Integer x)) = emitByte $ fromIntegral $ x emitParam (Param (Integer x)) = emitByte $ fromIntegral x
emitParam (Param (LabelRef Global l)) = emitBean $ Reference $ l emitParam (Param (LabelRef Global l)) = emitBean $ Reference l
emitParam (Param (LabelRef Local l)) = do emitParam (Param (LabelRef Local l)) = do
ctx <- lift get ctx <- lift get
scope <- case _currentLabel ctx of scope <- case _currentLabel ctx of
(Just s) -> return s (Just s) -> return s
Nothing -> throwError $ "Local label ('." ++ l ++ "') reference is allowed only in the global label scope" Nothing -> throwError $ "Local label ('." ++ l ++ "') reference is allowed only in the global label scope"
emitBean $ Reference $ (scope ++ "." ++ l) emitBean $ Reference (scope ++ "." ++ l)
emitParam _ = throwError "Number or label reference expected" emitParam _ = throwError "Number or label reference expected"
emitLabelDef :: Emitter emitLabelDef :: Emitter
@@ -50,7 +50,7 @@ emitLabelDef (LabelDef Global label) = do
ctx <- lift get ctx <- lift get
let labels = _labels ctx let labels = _labels ctx
let current = length (_beans ctx) let current = length (_beans ctx)
when (label `M.member` labels) (throwError $ "Label '" ++ (label) ++ "' is already defined") when (label `M.member` labels) (throwError $ "Label '" ++ label ++ "' is already defined")
put ctx { _labels = M.insert label current labels, _currentLabel = Just label } put ctx { _labels = M.insert label current labels, _currentLabel = Just label }
return () return ()
emitLabelDef (LabelDef Local label) = do emitLabelDef (LabelDef Local label) = do
@@ -61,9 +61,9 @@ emitLabelDef (LabelDef Local label) = do
Nothing -> throwError $ "Local label ('." ++ label ++ "') can be defined only in the global label scope" Nothing -> throwError $ "Local label ('." ++ label ++ "') can be defined only in the global label scope"
let canonicalLabel = scope ++ "." ++ label let canonicalLabel = scope ++ "." ++ label
let current = length (_beans ctx) let current = length (_beans ctx)
when (canonicalLabel `M.member` labels) (throwError $ "Label '" ++ (label) ++ "' is already defined in the global label '" ++ scope ++ "' scope") 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 } put ctx { _labels = M.insert canonicalLabel current labels }
return () return ()
emitLabelDef _ = throwError "Label definition expected" emitLabelDef _ = throwError "Label definition expected"
emitInstr :: Emitter emitInstr :: Emitter
@@ -71,7 +71,6 @@ emitInstr (Instruction (Operator op) Empty) = emitByte $ fromIntegral . fromEnum
emitInstr (Instruction (Operator op) (Params params)) = do emitInstr (Instruction (Operator op) (Params params)) = do
emitByte $ fromIntegral $ fromEnum op emitByte $ fromIntegral $ fromEnum op
mapM_ emitParam params mapM_ emitParam params
return ()
emitInstr _ = throwError "Instruction expected" emitInstr _ = throwError "Instruction expected"
emitLine :: Emitter emitLine :: Emitter
@@ -81,26 +80,26 @@ emitLine (Line labelDef instr) = emitLabelDef labelDef >> emitInstr instr >> ret
emitLine _ = throwError "Line of code expected" emitLine _ = throwError "Line of code expected"
emitProgram :: Emitter emitProgram :: Emitter
emitProgram (Program progLines) = mapM emitLine progLines >> return () emitProgram (Program progLines) = mapM_ emitLine progLines
emitProgram _ = throwError "Program code expected" emitProgram _ = throwError "Program code expected"
resolveLabels :: M.Map String Int -> [Bean] -> Either String [Bean] resolveLabels :: M.Map String Int -> [Bean] -> Either String [Bean]
resolveLabels labels beans = sequence $ foldr folder [] beans 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 :: M.Map String Int -> Bean -> Either String Bean
resolveLabel _ b@(Byte _) = Right b resolveLabel _ b@(Byte _) = Right b
resolveLabel labels (Reference label) = case M.lookup label labels of resolveLabel labels (Reference label) = case M.lookup label labels of
(Just t) -> Right . Byte . fromIntegral $ t (Just t) -> Right . Byte . fromIntegral $ t
Nothing -> Left $ "Label '" ++ label ++ "' is not defined" Nothing -> Left $ "Label '" ++ label ++ "' is not defined"
emit :: AST -> Either String [Word8] emit :: AST -> Either String [Word8]
emit root = do emit root = do
ctx <- flip evalState empty $ runExceptT $ emitProgram root >> lift get ctx <- flip evalState empty $ runExceptT $ emitProgram root >> lift get
let labels = _labels ctx let labels = _labels ctx
let beans = _beans ctx let beans = _beans ctx
resolved <- resolveLabels labels beans resolved <- resolveLabels labels beans
return $ map (\(Byte b) -> b) resolved return $ map (\(Byte b) -> b) resolved

45
app/Assembler/Parser.hs
View File

@@ -1,3 +1,4 @@
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
module Assembler.Parser where module Assembler.Parser where
import Data.List (intercalate) import Data.List (intercalate)
@@ -10,7 +11,7 @@ import Util (explode)
data Scope = Local | Global deriving (Eq, Show, Enum, Bounded) data Scope = Local | Global deriving (Eq, Show, Enum, Bounded)
data AST = Empty data AST = Empty
| Operator Op | Operator Op
| Integer Int | Integer Int
| Identifier String | Identifier String
| Colon | Colon
@@ -21,8 +22,8 @@ data AST = Empty
| Param AST | Param AST
| Params [AST] | Params [AST]
| Instruction AST AST | Instruction AST AST
| Line AST AST | Line AST AST
| Program [AST] | Program [AST]
deriving (Eq, Show) deriving (Eq, Show)
type ConsumedTokens = Int type ConsumedTokens = Int
@@ -43,36 +44,36 @@ parseInt _ = Nothing
-- ID := [alnum, '_']+ -- ID := [alnum, '_']+
parseIdentifier :: Parser parseIdentifier :: Parser
parseIdentifier ((T.Identifier iden):_) = Just $ ParseResult (Identifier iden) 1 parseIdentifier ((T.Identifier iden):_) = Just $ ParseResult (Identifier iden) 1
parseIdentifier _ = Nothing parseIdentifier _ = Nothing
-- ':' -- ':'
parseColon :: Parser parseColon :: Parser
parseColon ((T.Colon):_) = Just $ ParseResult Colon 1 parseColon (T.Colon:_) = Just $ ParseResult Colon 1
parseColon _ = Nothing parseColon _ = Nothing
-- '&' -- '&'
parseAmpersand :: Parser parseAmpersand :: Parser
parseAmpersand ((T.Ampersand):_) = Just $ ParseResult Ampersand 1 parseAmpersand (T.Ampersand:_) = Just $ ParseResult Ampersand 1
parseAmpersand _ = Nothing parseAmpersand _ = Nothing
-- '.' -- '.'
parseDot :: Parser parseDot :: Parser
parseDot ((T.Dot):_) = Just $ ParseResult Dot 1 parseDot (T.Dot:_) = Just $ ParseResult Dot 1
parseDot _ = Nothing parseDot _ = Nothing
-- label_def := '.'? ID ':' -- label_def := '.'? ID ':'
parseLabelDef :: Parser parseLabelDef :: Parser
parseLabelDef = parseSeq [parseOptionally parseDot, parseIdentifier, parseColon] combine 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 -- label_ref := '&' ID
parseLabelRef :: Parser parseLabelRef :: Parser
parseLabelRef = parseSeq [parseAmpersand, parseOptionally parseDot, parseIdentifier] combine 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 -- param := INT | label_ref
parseParam :: Parser parseParam :: Parser
@@ -107,17 +108,17 @@ parseMany :: Parser -> ([AST] -> AST) -> Parser
parseMany parser combiner tokens = if null asts parseMany parser combiner tokens = if null asts
then Nothing then Nothing
else Just $ ParseResult ast consumed else Just $ ParseResult ast consumed
where where
results = parseGreedy parser tokens results = parseGreedy parser tokens
consumed = sum $ map (\(ParseResult _ c) -> c) results consumed = sum $ map (\(ParseResult _ c) -> c) results
asts = map (\(ParseResult a _) -> a) results asts = map (\(ParseResult a _) -> a) results
ast = combiner asts ast = combiner asts
-- a a a a a a a... -- a a a a a a a...
parseGreedy :: Parser -> [T.Token] -> [ParseResult] parseGreedy :: Parser -> [T.Token] -> [ParseResult]
parseGreedy parser tokens = case parser tokens of parseGreedy parser tokens = case parser tokens of
(Just r@(ParseResult _ consumed)) -> r : parseGreedy parser (drop consumed tokens) (Just r@(ParseResult _ consumed)) -> r : parseGreedy parser (drop consumed tokens)
Nothing -> [] Nothing -> []
-- a | b | c -- a | b | c
parseAlt :: [Parser] -> (AST -> AST) -> Parser parseAlt :: [Parser] -> (AST -> AST) -> Parser
@@ -137,7 +138,7 @@ parseSeq parsers combiner tokens = do
results <- parseAll parsers tokens results <- parseAll parsers tokens
let consumed = sum $ map (\(ParseResult _ c) -> c) results let consumed = sum $ map (\(ParseResult _ c) -> c) results
let asts = map (\(ParseResult a _) -> a) results let asts = map (\(ParseResult a _) -> a) results
if (length asts) == (length parsers) if length asts == length parsers
then return $ ParseResult (combiner asts) consumed then return $ ParseResult (combiner asts) consumed
else Nothing else Nothing
@@ -147,7 +148,7 @@ parseAll [] _ = Just []
parseAll (p:ps) tokens = do parseAll (p:ps) tokens = do
(ParseResult ast consumed) <- p tokens (ParseResult ast consumed) <- p tokens
rest <- parseAll ps (drop consumed tokens) rest <- parseAll ps (drop consumed tokens)
return $ (ParseResult ast consumed) : rest return $ ParseResult ast consumed : rest
-- 'Nothing' if not consumed tokens exist -- 'Nothing' if not consumed tokens exist
assertConsumed :: Parser -> Parser assertConsumed :: Parser -> Parser
@@ -162,8 +163,8 @@ parse :: [T.Token] -> Either String AST
parse tokens = do parse tokens = do
let codeLines = explode (==T.NewLine) tokens let codeLines = explode (==T.NewLine) tokens
let results = map (assertConsumed parseLine) codeLines let results = map (assertConsumed parseLine) codeLines
let errors = filter ((==Nothing) . snd) $ zipWith (,) codeLines $ results let errors = filter ((==Nothing) . snd) $ zip codeLines results
let errorMsg = "Parse error(s):\n" ++ (intercalate "\n" $ map (show . fst) errors) let errorMsg = "Parse error(s):\n" ++ intercalate "\n" (map (show . fst) errors)
case sequenceA results of case sequenceA results of
(Just r) -> return $ Program $ map (\(ParseResult ast _) -> ast) r (Just r) -> return $ Program $ map (\(ParseResult ast _) -> ast) r
Nothing -> Left errorMsg Nothing -> Left errorMsg

53
app/Assembler/Tokenizer.hs
View File

@@ -8,8 +8,8 @@ import VirtualMachine.VM (Op(..))
import Util (toLowerCase, controlChar, unescape) import Util (toLowerCase, controlChar, unescape)
data Token = Operator Op data Token = Operator Op
| IntLiteral Int | IntLiteral Int
| StringLiteral String | StringLiteral String
| Identifier String | Identifier String
| Colon | Colon
@@ -38,59 +38,52 @@ keywordTokenizer cs kwd token input
matches = and zipped && len == length zipped matches = and zipped && len == length zipped
operatorTokenizer :: Op -> Tokenizer operatorTokenizer :: Op -> Tokenizer
operatorTokenizer op input = keywordTokenizer False (toLowerCase . show $ op) (Operator op) input operatorTokenizer op = keywordTokenizer False (toLowerCase . show $ op) (Operator op)
tokenizeOperators :: Tokenizer tokenizeOperators :: Tokenizer
tokenizeOperators = anyTokenizer $ map operatorTokenizer ops tokenizeOperators = anyTokenizer $ map operatorTokenizer $ sortBy cmp [Nop ..]
where where cmp x y = (length . show) y `compare` (length . show) x
ops = sortBy cmp [Nop ..]
cmp x y = (length . show) y `compare` (length . show) x
tokenizeIdentifier :: Tokenizer tokenizeIdentifier :: Tokenizer
tokenizeIdentifier [] = Nothing tokenizeIdentifier [] = Nothing
tokenizeIdentifier input@(x:_) = if null identifier || (not . isAlpha) x tokenizeIdentifier input@(x:_) = if null identifier || (not . isAlpha) x
then Nothing then Nothing
else Just $ TokenizeResult (Identifier identifier) (length identifier) else Just $ TokenizeResult (Identifier identifier) (length identifier)
where where identifier = takeWhile (or . sequenceA [isAlphaNum, (=='_')]) input
identifier = takeWhile (or . sequenceA [isAlphaNum, (=='_')]) input
tokenizeWhitespace :: Tokenizer tokenizeWhitespace :: Tokenizer
tokenizeWhitespace [] = Nothing tokenizeWhitespace [] = Nothing
tokenizeWhitespace (x:_) tokenizeWhitespace (x:_)
| isSpace x = Just $ TokenizeResult WhiteSpace 1 | isSpace x = Just $ TokenizeResult WhiteSpace 1
| otherwise = Nothing | otherwise = Nothing
tokenizeDecimal :: Tokenizer tokenizeDecimal :: Tokenizer
tokenizeDecimal [] = Nothing tokenizeDecimal [] = Nothing
tokenizeDecimal input = if null numberStr tokenizeDecimal input = if null numberStr
then Nothing then Nothing
else Just $ TokenizeResult (IntLiteral number) len else Just $ TokenizeResult (IntLiteral number) len
where where
number = read numberStr number = read numberStr
len = length numberStr len = length numberStr
numberStr = takeWhile isDigit input numberStr = takeWhile isDigit input
tokenizeHex :: Tokenizer tokenizeHex :: Tokenizer
tokenizeHex [] = Nothing tokenizeHex ('0':'x':input) = if null input
tokenizeHex input = if isPrefix && len > 0 then Nothing
then Just $ TokenizeResult (IntLiteral number) (len + 2) else Just $ TokenizeResult (IntLiteral $ read $ "0x" ++ numberStr) (length numberStr + 2)
else Nothing where numberStr = takeWhile isHexDigit input
where tokenizeHex _ = Nothing
isPrefix = take 2 input == "0x"
number = read . ("0x"++) $ numberStr
len = length numberStr
numberStr = takeWhile isHexDigit (drop 2 input)
tokenizeChar :: Tokenizer 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:'\'':_) = Just $ TokenizeResult (IntLiteral . ord $ x) 3
tokenizeChar _ = Nothing tokenizeChar _ = Nothing
tokenizeString :: Tokenizer tokenizeString :: Tokenizer
tokenizeString ('"':xs) = do tokenizeString ('"':xs) = do
string <- extractString xs string <- extractString xs
unescaped <- unescape string unescaped <- unescape string
return $ TokenizeResult (StringLiteral unescaped) (length string + 2) return $ TokenizeResult (StringLiteral unescaped) (length string + 2)
where where
extractString [] = Nothing extractString [] = Nothing
extractString (y:ys) extractString (y:ys)
@@ -100,13 +93,9 @@ tokenizeString ('"':xs) = do
tokenizeString _ = Nothing tokenizeString _ = Nothing
tokenizeComment :: Tokenizer tokenizeComment :: Tokenizer
tokenizeComment [] = Nothing tokenizeComment (';':xs) = Just $ TokenizeResult (Comment comment) (length comment + 1)
tokenizeComment (x:xs) = if x == ';' where comment = takeWhile (/='\n') xs
then Just $ TokenizeResult (Comment comment) (len + 1) tokenizeComment _ = Nothing
else Nothing
where
len = length comment
comment = takeWhile (/='\n') xs
type SeparatorPredicate = Char -> Bool type SeparatorPredicate = Char -> Bool
sepTokenizer :: SeparatorPredicate -> Tokenizer -> Tokenizer sepTokenizer :: SeparatorPredicate -> Tokenizer -> Tokenizer
@@ -115,7 +104,7 @@ sepTokenizer predicate tokenizer input = do
result@(TokenizeResult _ consumed) <- tokenizer input result@(TokenizeResult _ consumed) <- tokenizer input
let next = drop consumed input let next = drop consumed input
if null next || (predicate . head $ next) if null next || (predicate . head $ next)
then return $ result then return result
else Nothing else Nothing
anyTokenizer :: [Tokenizer] -> Tokenizer anyTokenizer :: [Tokenizer] -> Tokenizer
@@ -124,7 +113,7 @@ anyTokenizer tokenizers input = getFirst . mconcat . map First $ sequenceA token
tokenize :: String -> Either String [Token] tokenize :: String -> Either String [Token]
tokenize [] = Right [] tokenize [] = Right []
tokenize input = tokens >>= (\t -> Right $ filter tokenFilter t) tokenize input = tokens >>= (Right . filter tokenFilter)
where where
tokens = case tokenizers input of tokens = case tokenizers input of
(Just (TokenizeResult token chars)) -> tokenize (drop chars input) >>= (\rest -> return $ token : rest) (Just (TokenizeResult token chars)) -> tokenize (drop chars input) >>= (\rest -> return $ token : rest)
@@ -145,6 +134,6 @@ tokenize input = tokens >>= (\t -> Right $ filter tokenFilter t)
] ]
tokenFilter :: Token -> Bool tokenFilter :: Token -> Bool
tokenFilter (WhiteSpace) = False tokenFilter WhiteSpace = False
tokenFilter (Comment _) = False tokenFilter (Comment _) = False
tokenFilter _ = True tokenFilter _ = True

6
app/Main.hs
View File

@@ -1,8 +1,8 @@
module Main where module Main where
import System.Environment import System.Environment (getArgs)
import Runner (run, runDebug) import Runner (run)
main :: IO () main :: IO ()
main = do main = do
@@ -11,5 +11,5 @@ main = do
result <- run input result <- run input
case result of case result of
(Right vm) -> do (Right vm) -> do
putStrLn $ "\n\nDone:\n" ++ (show vm) putStrLn $ "\nDone\n" ++ show vm
(Left err) -> putStrLn $ "\n\nError:\n" ++ err (Left err) -> putStrLn $ "\n\nError:\n" ++ err

2
app/Runner.hs
View File

@@ -16,4 +16,4 @@ runDebug :: String -> IO (Either String VM)
runDebug = exec empty { _debug = True } runDebug = exec empty { _debug = True }
exec :: VM -> String -> IO (Either String VM) exec :: VM -> String -> IO (Either String VM)
exec vm input = runExceptT $ return input >>= (except . compile) >>= (liftIO . VM.run vm . B.pack) >>= except >>= return exec vm input = runExceptT $ (except . compile) input >>= (liftIO . VM.run vm . B.pack) >>= except

15
app/Util.hs
View File

@@ -9,7 +9,6 @@ module Util (
) where ) where
import Prelude hiding (head) import Prelude hiding (head)
import Data.List hiding (head)
import Data.Word (Word8) import Data.Word (Word8)
import Data.Char (chr, toLower) import Data.Char (chr, toLower)
import Numeric (showHex) import Numeric (showHex)
@@ -19,10 +18,10 @@ toLowerCase :: String -> String
toLowerCase = map toLower toLowerCase = map toLower
bytesStr :: Int -> [Word8] -> String bytesStr :: Int -> [Word8] -> String
bytesStr sparse = insertAtN '\n' (sparse*3) . intercalate " " . map byteStr bytesStr sparse = insertAtN '\n' (sparse*3) . unwords . map byteStr
byteStr :: Word8 -> String byteStr :: Word8 -> String
byteStr = pad '0' 2 . (flip showHex) "" . (fromIntegral :: Word8 -> Integer) byteStr = pad '0' 2 . flip showHex "" . (fromIntegral :: Word8 -> Integer)
insertAtN :: a -> Int -> [a] -> [a] insertAtN :: a -> Int -> [a] -> [a]
insertAtN c n xs = insertAtN' n xs insertAtN c n xs = insertAtN' n xs
@@ -40,7 +39,7 @@ head (x:_) = Just x
unescape :: String -> Maybe String unescape :: String -> Maybe String
unescape ('\\':x:xs) = do unescape ('\\':x:xs) = do
cc <- fmap chr $ controlChar x cc <- chr <$> controlChar x
rest <- unescape xs rest <- unescape xs
return $ cc : rest return $ cc : rest
unescape (x:xs) = unescape xs >>= (\rest -> return $ x : rest) unescape (x:xs) = unescape xs >>= (\rest -> return $ x : rest)
@@ -62,9 +61,9 @@ controlChar x = case x of
_ -> Nothing _ -> Nothing
explode :: (Foldable f) => (a -> Bool) -> f a -> [[a]] explode :: (Foldable f) => (a -> Bool) -> f a -> [[a]]
explode predicate xs = filter (not . null) $ foldr split [[]] xs 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

212
app/VirtualMachine/Instruction.hs
View File

@@ -1,46 +1,45 @@
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
module VirtualMachine.Instruction where module VirtualMachine.Instruction where
import Data.Char (chr, ord) import Data.Char (chr, ord)
import Data.Word (Word8) import Data.Word (Word8)
import System.IO (stdin, hGetChar) import Control.Monad (void)
import Control.Monad (unless)
import Control.Monad.Except (throwError) import Control.Monad.Except (throwError)
import Control.Monad.Trans (lift, liftIO) import Control.Monad.Trans (liftIO)
import Control.Monad.Trans.Except (ExceptT)
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Sequence as S import qualified Data.Sequence as S
import VirtualMachine.VM (Op(..), Machine, push, pop, forward, getAt, getPc, getFp, getStackSize, setAt, setPc, setFp, setHalt) import VirtualMachine.VM (Op(..), Computation, push, pop, forward, getPc, getFp, getStackSize, setPc, setFp, setHalt, frameAt, updateFrameAt)
type Params = [Int] type Params = [Int]
type Pops = [Int] type Pops = [Int]
type Pushes = S.Seq Int type Pushes = S.Seq Int
data Instruction = Simple { _op :: Op, _noParams :: Int, _noPops :: Int, _sAction :: Params -> Pops -> Pushes } data Instruction = Simple { _op :: Op, _noParams :: Int, _noPops :: Int, _sAction :: Params -> Pops -> Pushes }
| Complex { _op :: Op, _noParams :: Int, _noPops :: Int, _cAction :: Params -> Pops -> ExceptT String Machine () } | Complex { _op :: Op, _noParams :: Int, _noPops :: Int, _cAction :: Params -> Pops -> Computation () }
instance Show Instruction where instance Show Instruction where
show (Simple op noParams noPops _) = (show op) ++ "(S," ++ (show noParams) ++ "," ++ (show noPops) ++ ")" show (Simple op noParams noPops _) = show op ++ "(S," ++ show noParams ++ "," ++ show noPops ++ ")"
show (Complex op noParams noPops _) = (show op) ++ "(C," ++ (show noParams) ++ "," ++ (show noPops) ++ ")" show (Complex op noParams noPops _) = show op ++ "(C," ++ show noParams ++ "," ++ show noPops ++ ")"
data Unit = Instr { _instr :: Instruction } data Unit = Instr { _instr :: Instruction }
| Byte { _byte :: Word8 } | Byte { _byte :: Word8 }
deriving (Show) deriving (Show)
instructions :: [Instruction] instructions :: [Instruction]
instructions = [ Simple { _op = Nop, _noParams = 0, _noPops = 0, _sAction = (\_ _ -> S.empty) } instructions = [ Simple { _op = Nop, _noParams = 0, _noPops = 0, _sAction = \_ _ -> S.empty }
, Simple { _op = Push, _noParams = 1, _noPops = 0, _sAction = (\params _ -> S.fromList params) } , Simple { _op = Push, _noParams = 1, _noPops = 0, _sAction = \params _ -> S.fromList params }
, Simple { _op = Pop, _noParams = 0, _noPops = 1, _sAction = (\_ _ -> S.empty) } , Simple { _op = Pop, _noParams = 0, _noPops = 1, _sAction = \_ _ -> S.empty }
, Simple { _op = Dup, _noParams = 0, _noPops = 1, _sAction = (\_ [x] -> S.fromList [x, x]) } , Simple { _op = Dup, _noParams = 0, _noPops = 1, _sAction = \_ [x] -> S.fromList [x, x] }
, Simple { _op = Swap, _noParams = 0, _noPops = 2, _sAction = (\_ [x, y] -> S.fromList [y, x]) } , Simple { _op = Swap, _noParams = 0, _noPops = 2, _sAction = \_ [x, y] -> S.fromList [y, x] }
, Simple { _op = Add, _noParams = 0, _noPops = 2, _sAction = (\_ [x, y] -> S.fromList [y + x]) } , Simple { _op = Add, _noParams = 0, _noPops = 2, _sAction = \_ [x, y] -> S.fromList [y + x] }
, Simple { _op = Sub, _noParams = 0, _noPops = 2, _sAction = (\_ [x, y] -> S.fromList [y - x]) } , Simple { _op = Sub, _noParams = 0, _noPops = 2, _sAction = \_ [x, y] -> S.fromList [y - x] }
, Simple { _op = Mul, _noParams = 0, _noPops = 2, _sAction = (\_ [x, y] -> S.fromList [y * x]) } , Simple { _op = Mul, _noParams = 0, _noPops = 2, _sAction = \_ [x, y] -> S.fromList [y * x] }
, Simple { _op = Div, _noParams = 0, _noPops = 2, _sAction = (\_ [x, y] -> S.fromList [y `div` x]) } , Simple { _op = Div, _noParams = 0, _noPops = 2, _sAction = \_ [x, y] -> S.fromList [y `div` x] }
, Simple { _op = Neg, _noParams = 0, _noPops = 1, _sAction = (\_ [x] -> S.fromList [-x]) } , Simple { _op = Neg, _noParams = 0, _noPops = 1, _sAction = \_ [x] -> S.fromList [-x] }
, Simple { _op = Not, _noParams = 0, _noPops = 1, _sAction = (\_ [x] -> S.fromList [if x /= 0 then 0 else 1]) } , Simple { _op = Not, _noParams = 0, _noPops = 1, _sAction = \_ [x] -> S.fromList [if x /= 0 then 0 else 1] }
, Simple { _op = Over, _noParams = 0, _noPops = 2, _sAction = (\_ [x, y] -> S.fromList [y, x, y]) } , Simple { _op = Over, _noParams = 0, _noPops = 2, _sAction = \_ [x, y] -> S.fromList [y, x, y] }
, Complex { _op = Halt, _noParams = 0, _noPops = 0, _cAction = halt } , Complex { _op = Halt, _noParams = 0, _noPops = 0, _cAction = halt }
, Complex { _op = Call, _noParams = 1, _noPops = 0, _cAction = call } , Complex { _op = Call, _noParams = 1, _noPops = 0, _cAction = call }
, Complex { _op = Ret, _noParams = 0, _noPops = 0, _cAction = ret } , Complex { _op = Ret, _noParams = 0, _noPops = 0, _cAction = ret }
@@ -51,145 +50,68 @@ instructions = [ Simple { _op = Nop, _noParams = 0, _noPops = 0, _sAction = (\
, Complex { _op = Jl, _noParams = 1, _noPops = 1, _cAction = jumpIf (<) } , Complex { _op = Jl, _noParams = 1, _noPops = 1, _cAction = jumpIf (<) }
, Complex { _op = Jge, _noParams = 1, _noPops = 1, _cAction = jumpIf (>=) } , Complex { _op = Jge, _noParams = 1, _noPops = 1, _cAction = jumpIf (>=) }
, Complex { _op = Jle, _noParams = 1, _noPops = 1, _cAction = jumpIf (<=) } , Complex { _op = Jle, _noParams = 1, _noPops = 1, _cAction = jumpIf (<=) }
, Complex { _op = Lda, _noParams = 1, _noPops = 0, _cAction = load } , Complex { _op = Lda, _noParams = 1, _noPops = 0, _cAction = loadArg }
, Complex { _op = In, _noParams = 0, _noPops = 0, _cAction = input } , Complex { _op = In, _noParams = 0, _noPops = 0, _cAction = input }
, Complex { _op = Out, _noParams = 0, _noPops = 1, _cAction = output } , Complex { _op = Out, _noParams = 0, _noPops = 1, _cAction = output }
, Complex { _op = Clr, _noParams = 1, _noPops = 0, _cAction = clear } , Complex { _op = Clr, _noParams = 1, _noPops = 0, _cAction = clear }
, Complex { _op = Roll, _noParams = 0, _noPops = 0, _cAction = roll }
, Complex { _op = Ldl, _noParams = 1, _noPops = 0, _cAction = loadLocal } , Complex { _op = Ldl, _noParams = 1, _noPops = 0, _cAction = loadLocal }
, Complex { _op = Stl, _noParams = 1, _noPops = 1, _cAction = storeLocal } , Complex { _op = Stl, _noParams = 1, _noPops = 1, _cAction = storeLocal }
] ]
instructionByOp :: M.Map Op Instruction instructionByOp :: M.Map Op Instruction
instructionByOp = M.fromList $ map (\i -> (_op i, i)) instructions instructionByOp = M.fromList $ map (\i -> (_op i, i)) instructions
halt :: Params -> Pops -> ExceptT String Machine () halt :: Params -> Pops -> Computation ()
halt _ _ = lift $ do halt _ _ = setHalt True
setHalt True
return ()
call :: Params -> Pops -> ExceptT String Machine () call :: Params -> Pops -> Computation ()
call (addr:_) _ = lift $ do call (addr:_) _ = do
fp <- getFp fp <- getFp
fp' <- getStackSize fp' <- getStackSize
retAddr <- getPc >>= return . (+2) retAddr <- (+2) <$> getPc
push [retAddr, fp] push [retAddr, fp]
setPc addr setPc addr
setFp fp' setFp fp'
return () ret :: Params -> Pops -> Computation ()
call [] _ = throwError "Address excepted"
ret :: Params -> Pops -> ExceptT String Machine ()
ret _ _ = do ret _ _ = do
fp <- lift getFp
stackSize <- lift getStackSize
fp' <- getAt (stackSize - fp - 1) "Cannot determine previous frame pointer (fp)"
retAddr <- getAt (stackSize - fp - 2) "Cannot determine return address"
if stackSize - fp == 2
then lift $ do
_ <- pop $ stackSize - fp
return ()
else lift $ do
retVal <- pop 1
_ <- pop $ stackSize - fp - 1
push retVal
return ()
lift $ setFp fp'
lift $ setPc retAddr
return ()
jump :: Params -> Pops -> ExceptT String Machine ()
jump (addr:_) _ = lift $ do
setPc addr
return ()
jump [] _ = throwError "Address expected"
jumpIf :: (Int -> Int -> Bool) -> Params -> Pops -> ExceptT String Machine ()
jumpIf p (addr:_) (top:_) = lift $ do
pc <- getPc
push [top]
setPc $ if top `p` 0 then addr else pc + 2
return ()
jumpIf _ [] _ = throwError "Address expected"
jumpIf _ _ [] = throwError "Empty stack - nothing to compare"
input :: Params -> Pops -> ExceptT String Machine ()
input _ _ = lift $ do
c <- liftIO $ hGetChar stdin
push [ord c]
forward 1
return()
output :: Params -> Pops -> ExceptT String Machine ()
output _ (char:_) = lift $ do
liftIO $ putStr $ [chr char]
forward 1
return ()
output _ [] = throwError $ "Empty stack - nothing to output"
load :: Params -> Pops -> ExceptT String Machine ()
load (index:_) _ = do
fp <- lift getFp
stackSize <- lift getStackSize
val <- getAt (stackSize - fp + index) ("Index " ++ (show index) ++ " out of stack bounds")
lift $ push [val]
lift $ forward 2
return ()
load [] _ = throwError "Local parameter index expected"
niy :: Op -> Params -> Pops -> ExceptT String Machine ()
niy op _ _ = do
pc <- lift getPc
throwError $ "Instruction '" ++ (show op) ++ "' ("++ (show $ pc) ++") is not implemented yet"
clear :: Params -> Pops -> ExceptT String Machine ()
clear (count:_) _ = lift $ do
top <- pop 1
_ <- pop count
push top
forward 2
return ()
clear [] _ = throwError "Number of elements to be cleaned expected"
roll :: Params -> Pops -> ExceptT String Machine ()
roll _ _ = lift $ do
fp <- getFp fp <- getFp
stackSize <- getStackSize stackSize <- getStackSize
let offset = if fp == -1 then 0 else (fp + 2)
substack <- pop $ stackSize - offset
if null substack
then return ()
else do
let (x:xs) = substack
push $ xs ++ [x]
return ()
forward 1
return ()
loadLocal :: Params -> Pops -> ExceptT String Machine () fp' <- frameAt 0 id "frame pointer (fp)"
loadLocal (index:_) _ = do retAddr <- frameAt 1 id "return address"
fp <- lift getFp
unless (fp > -1) (throwError "No active stack frame to load local variable")
stackSize <- lift getStackSize
val <- getAt (stackSize - fp - 3 - index) $ "No stack value on the active frame under the index: " ++ (show index)
lift $ push [val]
lift $ forward 2
return ()
loadLocal [] _ = throwError "Local variable index expected"
storeLocal :: Params -> Pops -> ExceptT String Machine () if stackSize - fp == 2
storeLocal (index:_) (val:_) = do then void $ pop (stackSize - fp)
fp <- lift getFp else pop 1 >>= \retVal -> pop (stackSize - fp - 1) >> push retVal
unless (fp > -1) (throwError "No active stack frame to store local variable")
stackSize <- lift getStackSize setFp fp'
lift $ setAt (stackSize - fp - 3 - index) val setPc retAddr
lift $ forward 2
return () jump :: Params -> Pops -> Computation ()
storeLocal [] _ = throwError "Local variable index expected" jump (addr:_) _ = setPc addr
storeLocal _ [] = throwError "Empty stack - nothing to store"
jumpIf :: (Int -> Int -> Bool) -> Params -> Pops -> Computation ()
jumpIf p (addr:_) (top:_) = push [top] >> getPc >>= (\pc -> return $ if top `p` 0 then addr else pc + 2) >>= setPc
input :: Params -> Pops -> Computation ()
input _ _ = liftIO getChar >>= \c -> push [ord c] >> forward 1
output :: Params -> Pops -> Computation ()
output _ (char:_) = liftIO (putStr [chr char]) >> forward 1
loadArg :: Params -> Pops -> Computation ()
loadArg (index:_) _ = frameAt index (\x -> -x - 1) "call argument" >>= \val -> push [val] >> forward 2
clear :: Params -> Pops -> Computation ()
clear (count:_) _ = pop 1 >>= \top -> pop count >> push top >> forward 2
loadLocal :: Params -> Pops -> Computation ()
loadLocal (index:_) _ = frameAt index (+2) "local variable" >>= \val -> push [val] >> forward 2
storeLocal :: Params -> Pops -> Computation ()
storeLocal (index:_) (val:_) = updateFrameAt (index + 2) val >> forward 2
niy :: Op -> Params -> Pops -> Computation ()
niy op _ _ = getPc >>= \pc -> throwError $ "Instruction '" ++ show op ++ "' ("++ show pc ++") is not implemented yet"

82
app/VirtualMachine/Interpreter.hs
View File

@@ -4,15 +4,14 @@ import Data.Word (Word8)
import Data.List (intercalate) import Data.List (intercalate)
import Control.Monad (when, unless) import Control.Monad (when, unless)
import Control.Monad.Trans.State (get, evalStateT) import Control.Monad.Trans.State (evalStateT)
import Control.Monad.Trans.Except (ExceptT, except, runExceptT) import Control.Monad.Trans.Except (except, runExceptT)
import Control.Monad.Trans (lift)
import Control.Monad.Except (throwError) import Control.Monad.Except (throwError)
import Control.Monad.State (liftIO) import Control.Monad.State (liftIO)
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.ByteString as B import qualified Data.ByteString as B
import VirtualMachine.VM (VM(..), Op, Machine, pop, pushS, forward, getPc, isHalted, isDebug) import VirtualMachine.VM (VM(..), Op, Computation, get, pop, pushS, forward, getPc, isHalted, isDebug)
import VirtualMachine.Instruction (Instruction(..), Unit(..), instructionByOp) import VirtualMachine.Instruction (Instruction(..), Unit(..), instructionByOp)
@@ -24,7 +23,7 @@ parseInstr (opCode:rest) = do
Nothing -> Left "Unknown instruction" Nothing -> Left "Unknown instruction"
let noParams = _noParams instr let noParams = _noParams instr
let params = map fromIntegral $ take noParams rest :: [Word8] 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) ++ "'") unless (length params == noParams) (Left $ "Expected " ++ show noParams ++ " parameter(s), got " ++ show (length params) ++ " for operator '" ++ show op ++ "'")
return (instr, params) return (instr, params)
parseInstr [] = Left "Unexpected end of the file" parseInstr [] = Left "Unexpected end of the file"
@@ -37,68 +36,61 @@ parse code = do
rest <- parse (drop (noParams + 1) code) rest <- parse (drop (noParams + 1) code)
return $ [Instr instr] ++ paramBytes ++ rest return $ [Instr instr] ++ paramBytes ++ rest
interpret :: [Unit] -> ExceptT String Machine () interpret :: [Unit] -> Computation ()
interpret units = do interpret units = isHalted >>= \halted -> unless halted $ interpretUnit units >> interpret units
halted <- lift isHalted
if halted interpretUnit :: [Unit] -> Computation ()
then return ()
else do
interpretUnit units
interpret units
interpretUnit :: [Unit] -> ExceptT String Machine ()
interpretUnit [] = throwError "Nothing to interpret" interpretUnit [] = throwError "Nothing to interpret"
interpretUnit units = do interpretUnit units = do
pc <- lift getPc pc <- getPc
let progSize = length units let progSize = length units
unless (pc < progSize) (throwError $ "PC (=" ++ (show pc) ++ ") exceeds program size (=" ++ (show progSize) ++ ")") unless (pc < progSize) (throwError $ "PC (=" ++ show pc ++ ") exceeds program size (=" ++ show progSize ++ ")")
case units !! pc of case units !! pc of
(Instr instr) -> dispatchInstr units instr (Instr instr) -> dispatchInstr units instr
(Byte _) -> throwError $ "PC (=" ++ (show pc) ++ ") currently points to the data byte rather than instruction" (Byte _) -> throwError $ "PC (=" ++ show pc ++ ") currently points to the data byte rather than instruction"
dispatchInstr :: [Unit] -> Instruction -> ExceptT String Machine () dispatchInstr :: [Unit] -> Instruction -> Computation ()
dispatchInstr units instr = do dispatchInstr units instr = do
debug <- lift isDebug debug <- isDebug
when debug $ lift $ do when debug $ do
vm <- get vm <- get
pc <- getPc pc <- getPc
let noParams = _noParams instr let noParams = _noParams instr
let params = intercalate "" $ map (show . _byte) $ take noParams $ drop (pc + 1) $ units let params = intercalate "" $ map (show . _byte) $ take noParams $ drop (pc + 1) units
liftIO $ putStrLn $ show vm liftIO $ print vm
liftIO $ putStrLn $ (show pc) ++ ": " ++ (show $ _op instr) ++ " " ++ params liftIO $ putStrLn $ show pc ++ ": " ++ show (_op instr) ++ " " ++ params
case instr of case instr of
Simple {} -> interpretSimple units instr Simple {} -> interpretSimple units instr
Complex {} -> interpretComplex units instr Complex {} -> interpretComplex units instr
interpretSimple :: [Unit] -> Instruction -> ExceptT String Machine () interpretSimple :: [Unit] -> Instruction -> Computation ()
interpretSimple units instr = do interpretSimple units instr = do
pc <- lift getPc pc <- getPc
let noParams = _noParams instr let noParams = _noParams instr
let noPops = _noPops instr let noPops = _noPops instr
let paramBytes = take noParams $ drop (pc + 1) $ units let paramBytes = take noParams $ drop (pc + 1) units
let params = map (fromIntegral . _byte) paramBytes let params = map (fromIntegral . _byte) paramBytes
let action = _sAction instr let action = _sAction instr
pops <- lift $ pop noPops pops <- pop noPops
unless (length pops == noPops) (throwError $ "Attempt to pop from empty stack: tried to pop " ++ (show noPops) ++ " elements, got " ++ (show $ length pops)) unless (length pops == noPops) (throwError $ "Attempt to pop from empty stack: tried to pop " ++ show noPops ++ " elements, got " ++ show (length pops))
let pushes = action params pops let pushes = action params pops
lift $ pushS pushes pushS pushes
lift $ forward $ noParams + 1 forward $ noParams + 1
return ()
interpretComplex :: [Unit] -> Instruction -> ExceptT String Machine () interpretComplex :: [Unit] -> Instruction -> Computation ()
interpretComplex units instr = do interpretComplex units instr = do
pc <- lift getPc pc <- getPc
let noParams = _noParams instr let noParams = _noParams instr
let noPops = _noPops instr let noPops = _noPops instr
let paramBytes = take noParams $ drop (pc + 1) $ units let paramBytes = take noParams $ drop (pc + 1) units
let params = map (fromIntegral . _byte) paramBytes let params = map (fromIntegral . _byte) paramBytes
let action = _cAction instr let action = _cAction instr
pops <- lift $ pop noPops pops <- pop noPops
unless (length pops == noPops) (throwError $ "Attempt to pop from empty stack: tried to pop " ++ (show noPops) ++ " elements, got " ++ (show $ length pops)) unless (length pops == noPops) (throwError $ "Attempt to pop from empty stack: tried to pop " ++ show noPops ++ " elements, got " ++ show (length pops))
action params pops action params pops
run :: VM -> B.ByteString -> IO (Either String VM) run :: VM -> B.ByteString -> IO (Either String VM)
run vm input = evalStateT (runExceptT machine) vm run vm input = evalStateT (runExceptT machine) vm
where machine = (return input) >>= (return .B.unpack) >>= (except . parse) >>= interpret >> (lift get) where machine = (except . parse . B.unpack) input >>= interpret >> get

109
app/VirtualMachine/VM.hs
View File

@@ -3,11 +3,13 @@ module VirtualMachine.VM where
import Text.Printf (printf) import Text.Printf (printf)
import Data.Foldable (toList) import Data.Foldable (toList)
import Control.Monad.Trans (lift) import Control.Monad.Trans (lift)
import Control.Monad.State (get, put)
import Control.Monad.Except (throwError) import Control.Monad.Except (throwError)
import Control.Monad.Trans.State (StateT) import Control.Monad.Trans.State (StateT)
import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Except (ExceptT)
import qualified Data.Sequence as S import qualified Data.Sequence as S
import qualified Control.Monad.State as ST (get, put)
import Data.Functor ((<&>))
import Control.Monad (unless)
data VM = VM { _pc :: Int data VM = VM { _pc :: Int
@@ -45,14 +47,15 @@ data Op = Nop -- 0x00
| In -- 0x16 | In -- 0x16
| Out -- 0x17 | Out -- 0x17
| Clr -- 0x18 | Clr -- 0x18
| Roll -- 0x19 | Over -- 0x19
| Over -- 0x1A | Ldl -- 0x1A
| Ldl -- 0x1B | Stl -- 0x1B
| Stl -- 0x1C
deriving (Eq, Ord, Enum, Show, Read, Bounded) deriving (Eq, Ord, Enum, Show, Read, Bounded)
type Machine = StateT VM IO type Machine = StateT VM IO
type Computation = ExceptT String Machine
empty :: VM empty :: VM
empty = VM { _pc = 0 empty = VM { _pc = 0
, _fp = -1 , _fp = -1
@@ -63,69 +66,71 @@ empty = VM { _pc = 0
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
getPc :: Machine Int get :: Computation VM
getPc = get >>= (return . _pc) get = lift ST.get
getFp :: Machine Int put :: VM -> Computation ()
getFp = get >>= (return . _fp) put x = lift $ ST.put x
isHalted :: Machine Bool getPc :: Computation Int
isHalted = get >>= (return . _halt) getPc = get <&> _pc
isDebug :: Machine Bool getFp :: Computation Int
isDebug = get >>= (return . _debug) getFp = get <&> _fp
getAt :: Int -> String -> ExceptT String Machine Int isHalted :: Computation Bool
getAt index err = do isHalted = get <&> _halt
vm <- lift $ get
let stack = _stack vm isDebug :: Computation Bool
case (stack S.!? index) of isDebug = get <&> _debug
stackAt :: Int -> String -> Computation Int
stackAt index err = get >>= \vm -> case _stack vm S.!? index of
(Just i) -> return i
Nothing -> throwError err
frameAt :: Int -> (Int -> Int) -> String -> Computation Int
frameAt index t name = do
vm <- get
fp <- getFp
unless (fp > -1) (throwError "No active stack frame")
stackSize <- getStackSize
case _stack vm S.!? (stackSize - fp - 1 - t index) of
(Just i) -> return i (Just i) -> return i
Nothing -> throwError err Nothing -> throwError $ "Cannot determine " ++ name ++ " - index " ++ show index ++ " out of frame bounds"
setAt :: Int -> Int -> Machine () updateFrameAt :: Int -> Int -> Computation ()
setAt index val = do updateFrameAt index value = do
vm <- get vm <- get
let stack = _stack vm fp <- getFp
let stack' = S.update index val stack unless (fp > -1) (throwError "No active stack frame")
put vm { _stack = stack' } stackSize <- getStackSize
put vm { _stack = S.update (stackSize - fp - 1 - index) value $ _stack vm }
getStackSize :: Machine Int getStackSize :: Computation Int
getStackSize = get >>= (return . length . _stack) getStackSize = get <&> (length . _stack)
setPc :: Int -> Machine () setPc :: Int -> Computation ()
setPc pc = do setPc pc = get >>= \vm -> put vm { _pc = pc }
vm <- get
put vm { _pc = pc }
setFp :: Int -> Machine () setFp :: Int -> Computation ()
setFp fp = do setFp fp = get >>= \vm -> put vm { _fp = fp }
vm <- get
put vm { _fp = fp }
setHalt :: Bool -> Machine () setHalt :: Bool -> Computation ()
setHalt halt = do setHalt halt = get >>= \vm -> put vm { _halt = halt }
vm <- get
put vm { _halt = halt }
pop :: Int -> Machine [Int] pop :: Int -> Computation [Int]
pop count = do pop count = do
vm <- get vm <- get
let stack = _stack vm let stack = _stack vm
put vm { _stack = S.drop count $ stack } put vm { _stack = S.drop count stack }
return $ toList $ S.take count $ stack return $ toList $ S.take count stack
push :: [Int] -> Machine () push :: [Int] -> Computation ()
push = pushS . S.fromList push = pushS . S.fromList
pushS :: S.Seq Int -> Machine () pushS :: S.Seq Int -> Computation ()
pushS numbers = do pushS numbers = get >>= \vm -> put vm { _stack = numbers <> _stack vm }
vm <- get
put vm { _stack = numbers <> _stack vm }
return ()
forward :: Int -> Machine () forward :: Int -> Computation ()
forward offset = do forward offset = get >>= \vm -> put vm { _pc = _pc vm + offset }
vm <- get
put vm { _pc = _pc vm + offset }
return ()

16
test/Assembler/EmitterSpec.hs
View File

@@ -13,7 +13,7 @@ import Assembler.Emitter as E
import VirtualMachine.VM (Op(..)) import VirtualMachine.VM (Op(..))
evalContext :: Context -> AST -> Emitter -> Either String Context evalContext :: Context -> AST -> Emitter -> Either String Context
evalContext ctx ast emitter = flip evalState ctx $ runExceptT $ emitter ast >> lift get evalContext ctx ast emitter = flip evalState ctx $ runExceptT $ emitter ast >> lift get
spec :: Spec spec :: Spec
spec = do spec = do
@@ -37,12 +37,12 @@ spec = do
let ctx = E.empty { _labels = M.fromList [("main", 0)], _currentLabel = Just "main" } let ctx = E.empty { _labels = M.fromList [("main", 0)], _currentLabel = Just "main" }
let input = LabelDef Local "foo" let input = LabelDef Local "foo"
let expected = Right (ctx { _labels = M.fromList [("main", 0), ("main.foo", 0)], _currentLabel = Just "main" }) let expected = Right (ctx { _labels = M.fromList [("main", 0), ("main.foo", 0)], _currentLabel = Just "main" })
evalContext ctx input emitLabelDef `shouldBe` expected evalContext ctx input emitLabelDef `shouldBe` expected
it "allows for the same local label in different global label scopes" $ do it "allows for the same local label in different global label scopes" $ do
let ctx = E.empty { _labels = M.fromList [("main", 0), ("main.foo", 0), ("program", 0)], _currentLabel = Just "program" } let ctx = E.empty { _labels = M.fromList [("main", 0), ("main.foo", 0), ("program", 0)], _currentLabel = Just "program" }
let input = LabelDef Local "foo" let input = LabelDef Local "foo"
let expected = Right (ctx { _labels = M.fromList [("main", 0), ("main.foo", 0), ("program", 0), ("program.foo", 0)], _currentLabel = Just "program" }) let expected = Right (ctx { _labels = M.fromList [("main", 0), ("main.foo", 0), ("program", 0), ("program.foo", 0)], _currentLabel = Just "program" })
evalContext ctx input emitLabelDef `shouldBe` expected evalContext ctx input emitLabelDef `shouldBe` expected
it "does not allow to redefine local label" $ do it "does not allow to redefine local label" $ do
let ctx = E.empty { _labels = M.fromList [("main", 0), ("main.foo", 0)], _currentLabel = Just "main" } let ctx = E.empty { _labels = M.fromList [("main", 0), ("main.foo", 0)], _currentLabel = Just "main" }
let input = LabelDef Local "foo" let input = LabelDef Local "foo"
@@ -84,7 +84,7 @@ spec = do
evalContext ctx input emitInstr `shouldBe` expected evalContext ctx input emitInstr `shouldBe` expected
it "emits bytes for 2-param instruction" $ do it "emits bytes for 2-param instruction" $ do
let ctx = E.empty let ctx = E.empty
let input = Instruction (Operator Push) (Params [(Param (Integer 11)), (Param (LabelRef Global "main"))]) let input = Instruction (Operator Push) (Params [Param (Integer 11), Param (LabelRef Global "main")])
let expected = Right (ctx { _beans = [Byte 0x02, Byte 0x0B, Reference "main"] }) let expected = Right (ctx { _beans = [Byte 0x02, Byte 0x0B, Reference "main"] })
evalContext ctx input emitInstr `shouldBe` expected evalContext ctx input emitInstr `shouldBe` expected
@@ -106,7 +106,7 @@ spec = do
\ push 2 \n\ \ push 2 \n\
\ jmp &sum \n\ \ jmp &sum \n\
\ sum: add \n\ \ sum: add \n\
\ jmp &main " \ jmp &main "
let (Right tokens) = tokenize input let (Right tokens) = tokenize input
let (Right ast) = parse tokens let (Right ast) = parse tokens
let expected = [0x02, 0x01, 0x02, 0x02, 0x0e, 0x06, 0x06, 0x0e, 0x00] let expected = [0x02, 0x01, 0x02, 0x02, 0x0e, 0x06, 0x06, 0x0e, 0x00]
@@ -123,7 +123,7 @@ spec = do
\ push 2 \n\ \ push 2 \n\
\ jmp &.sum \n\ \ jmp &.sum \n\
\ .sum: add \n\ \ .sum: add \n\
\ jmp &.loop " \ jmp &.loop "
let (Right tokens) = tokenize input let (Right tokens) = tokenize input
let (Right ast) = parse tokens let (Right ast) = parse tokens
-- The differences: &.sum &.loop -- The differences: &.sum &.loop
@@ -138,7 +138,7 @@ spec = do
\ push 2 \n\ \ push 2 \n\
\ jmp &sum \n\ \ jmp &sum \n\
\ sum: add \n\ \ sum: add \n\
\ jmp &program " \ jmp &program "
let (Right tokens) = tokenize input let (Right tokens) = tokenize input
let (Right ast) = parse tokens let (Right ast) = parse tokens
emit ast `shouldBe` Left "Label 'program' is not defined" emit ast `shouldBe` Left "Label 'program' is not defined"

253
test/Assembler/ParserSpec.hs
View File

@@ -17,8 +17,7 @@ spec = do
let input = map ((:[]) . T.Operator) ops let input = map ((:[]) . T.Operator) ops
let expected = map (flip success 1 . Operator) ops let expected = map (flip success 1 . Operator) ops
map parseOperator input `shouldBe` expected map parseOperator input `shouldBe` expected
it "supports non-truncated input" $ do it "supports non-truncated input" $ parseOperator [T.Operator Call, T.Ampersand, T.Identifier "label"] `shouldBe` success (Operator Call) 1
parseOperator [T.Operator Call, T.Ampersand, T.Identifier "label"] `shouldBe` success (Operator Call) 1
it "supports empty input" $ it "supports empty input" $
parseOperator [] `shouldBe` Nothing parseOperator [] `shouldBe` Nothing
@@ -28,35 +27,31 @@ spec = do
let input = map ((:[]) . T.IntLiteral) ints let input = map ((:[]) . T.IntLiteral) ints
let expected = map (flip success 1 . Integer) ints let expected = map (flip success 1 . Integer) ints
map parseInt input `shouldBe` expected map parseInt input `shouldBe` expected
it "supports non-truncated input" $ do it "supports non-truncated input" $ parseInt [T.IntLiteral 4, T.Colon] `shouldBe` success (Integer 4) 1
parseInt [T.IntLiteral 4, T.Colon] `shouldBe` success (Integer 4) 1
it "supports empty input" $ it "supports empty input" $
parseInt [] `shouldBe` Nothing parseInt [] `shouldBe` Nothing
describe "parseIdentifier" $ do describe "parseIdentifier" $ do
it "accepts identifier tokens" $ it "accepts identifier tokens" $
parseIdentifier [T.Identifier "someId"] `shouldBe` success (Identifier "someId") 1 parseIdentifier [T.Identifier "someId"] `shouldBe` success (Identifier "someId") 1
it "supports non-truncated input" $ do it "supports non-truncated input" $ parseIdentifier [T.Identifier "label", T.Colon] `shouldBe` success (Identifier "label") 1
parseIdentifier [T.Identifier "label", T.Colon] `shouldBe` success (Identifier "label") 1
it "supports empty input" $ it "supports empty input" $
parseIdentifier [] `shouldBe` Nothing parseIdentifier [] `shouldBe` Nothing
describe "parseColon" $ do describe "parseColon" $ do
it "accepts colon tokens" $ it "accepts colon tokens" $
parseColon [T.Colon] `shouldBe` success Colon 1 parseColon [T.Colon] `shouldBe` success Colon 1
it "supports non-truncated input" $ do it "supports non-truncated input" $ parseColon [T.Colon, T.Operator Add] `shouldBe` success Colon 1
parseColon [T.Colon, T.Operator Add] `shouldBe` success Colon 1
it "supports empty input" $ it "supports empty input" $
parseColon [] `shouldBe` Nothing parseColon [] `shouldBe` Nothing
describe "parseAmpersand" $ do describe "parseAmpersand" $ do
it "accepts colon tokens" $ it "accepts colon tokens" $
parseAmpersand [T.Ampersand] `shouldBe` success Ampersand 1 parseAmpersand [T.Ampersand] `shouldBe` success Ampersand 1
it "supports non-truncated input" $ do it "supports non-truncated input" $ parseAmpersand [T.Ampersand, T.Identifier "label"] `shouldBe` success Ampersand 1
parseAmpersand [T.Ampersand, T.Identifier "label"] `shouldBe` success Ampersand 1
it "supports empty input" $ it "supports empty input" $
parseAmpersand [] `shouldBe` Nothing parseAmpersand [] `shouldBe` Nothing
describe "parseLabelDef" $ do describe "parseLabelDef" $ do
it "parses global label def" $ it "parses global label def" $
parseLabelDef [T.Identifier "label", T.Colon] `shouldBe` success (LabelDef Global "label") 2 parseLabelDef [T.Identifier "label", T.Colon] `shouldBe` success (LabelDef Global "label") 2
@@ -65,9 +60,8 @@ spec = do
it "requires label" $ it "requires label" $
parseLabelDef [T.Colon] `shouldBe` Nothing parseLabelDef [T.Colon] `shouldBe` Nothing
it "requires colon" $ it "requires colon" $
parseLabelDef [T.Identifier "label"] `shouldBe` Nothing parseLabelDef [T.Identifier "label"] `shouldBe` Nothing
it "supports non-truncated input" $ do it "supports non-truncated input" $ parseLabelDef [T.Identifier "sum", T.Colon, T.Operator Nop] `shouldBe` success (LabelDef Global "sum") 2
parseLabelDef [T.Identifier "sum", T.Colon, T.Operator Nop] `shouldBe` success (LabelDef Global "sum") 2
it "supports empty input" $ it "supports empty input" $
parseLabelDef [] `shouldBe` Nothing parseLabelDef [] `shouldBe` Nothing
@@ -79,11 +73,10 @@ spec = do
it "requires label" $ it "requires label" $
parseLabelRef [T.Ampersand] `shouldBe` Nothing parseLabelRef [T.Ampersand] `shouldBe` Nothing
it "requires ampersand" $ it "requires ampersand" $
parseLabelRef [T.Identifier "label"] `shouldBe` Nothing parseLabelRef [T.Identifier "label"] `shouldBe` Nothing
it "supports non-truncated input" $ do it "supports non-truncated input" $ parseLabelRef [T.Ampersand, T.Identifier "sum", T.Operator Nop] `shouldBe` success (LabelRef Global "sum") 2
parseLabelRef [T.Ampersand, T.Identifier "sum", T.Operator Nop] `shouldBe` success (LabelRef Global "sum") 2
it "supports empty input" $ it "supports empty input" $
parseLabelRef [] `shouldBe` Nothing parseLabelRef [] `shouldBe` Nothing
describe "parseParam" $ do describe "parseParam" $ do
it "parses int params" $ do it "parses int params" $ do
@@ -96,9 +89,9 @@ spec = do
parseParam [T.Ampersand, T.Identifier "program"] `shouldBe` expected parseParam [T.Ampersand, T.Identifier "program"] `shouldBe` expected
it "supports non-truncated input" $ do it "supports non-truncated input" $ do
let expected = success (Param (Integer 1)) 1 let expected = success (Param (Integer 1)) 1
parseParam [T.IntLiteral 1, T.IntLiteral 2, T.IntLiteral 3] `shouldBe` expected parseParam [T.IntLiteral 1, T.IntLiteral 2, T.IntLiteral 3] `shouldBe` expected
it "supports empty input" $ it "supports empty input" $
parseParam [] `shouldBe` Nothing parseParam [] `shouldBe` Nothing
describe "parseInstr" $ do describe "parseInstr" $ do
it "parses no-param operator" $ do it "parses no-param operator" $ do
@@ -113,53 +106,53 @@ spec = do
let expected = success (Instruction let expected = success (Instruction
(Operator Push) (Operator Push)
(Params [ (Params [
(Param (Integer 4)) Param (Integer 4)
]) ])
) (length input) ) (length input)
parseInstr input `shouldBe` expected parseInstr input `shouldBe` expected
it "parses operator with single label ref param" $ do it "parses operator with single label ref param" $ do
let input = [T.Operator Call, T.Ampersand, T.Identifier "program"] let input = [T.Operator Call, T.Ampersand, T.Identifier "program"]
let expected = success (Instruction let expected = success (Instruction
(Operator Call) (Operator Call)
(Params [ (Params [
(Param (LabelRef Global "program")) Param (LabelRef Global "program")
]) ])
) (length input) ) (length input)
parseInstr input `shouldBe` expected parseInstr input `shouldBe` expected
it "parses operator with multiple int params" $ do it "parses operator with multiple int params" $ do
let input = [T.Operator Push let input = [T.Operator Push
, T.IntLiteral 1 , T.IntLiteral 1
, T.IntLiteral 4 , T.IntLiteral 4
, T.IntLiteral 2 , T.IntLiteral 2
, T.IntLiteral 0 , T.IntLiteral 0
] ]
let expected = success (Instruction let expected = success (Instruction
(Operator Push) (Operator Push)
(Params [ (Params [
(Param (Integer 1)), Param (Integer 1),
(Param (Integer 4)), Param (Integer 4),
(Param (Integer 2)), Param (Integer 2),
(Param (Integer 0)) Param (Integer 0)
]) ])
) (length input) ) (length input)
parseInstr input `shouldBe` expected parseInstr input `shouldBe` expected
it "parses operator with multiple param ref params" $ do it "parses operator with multiple param ref params" $ do
let input = [T.Operator Push let input = [T.Operator Push
, T.Ampersand, T.Dot, T.Identifier "program" , T.Ampersand, T.Dot, T.Identifier "program"
, T.Ampersand, T.Dot, T.Identifier "main" , T.Ampersand, T.Dot, T.Identifier "main"
, T.Ampersand, T.Identifier "foo" , T.Ampersand, T.Identifier "foo"
, T.Ampersand, T.Dot, T.Identifier "bar" , T.Ampersand, T.Dot, T.Identifier "bar"
] ]
let expected = success (Instruction let expected = success (Instruction
(Operator Push) (Operator Push)
(Params [ (Params [
(Param (LabelRef Local "program")), Param (LabelRef Local "program"),
(Param (LabelRef Local "main")), Param (LabelRef Local "main"),
(Param (LabelRef Global "foo")), Param (LabelRef Global "foo"),
(Param (LabelRef Local "bar")) Param (LabelRef Local "bar")
]) ])
) (length input) ) (length input)
parseInstr input `shouldBe` expected parseInstr input `shouldBe` expected
it "parses operator with multiple mixed params" $ do it "parses operator with multiple mixed params" $ do
let input = [T.Operator Push let input = [T.Operator Push
, T.Ampersand, T.Identifier "program" , T.Ampersand, T.Identifier "program"
@@ -170,21 +163,21 @@ spec = do
, T.IntLiteral 11 , T.IntLiteral 11
, T.Ampersand, T.Dot, T.Identifier "bar" , T.Ampersand, T.Dot, T.Identifier "bar"
, T.IntLiteral 20 , T.IntLiteral 20
] ]
let expected = success (Instruction let expected = success (Instruction
(Operator Push) (Operator Push)
(Params [ (Params [
(Param (LabelRef Global "program")), Param (LabelRef Global "program"),
(Param (Integer 4)), Param (Integer 4),
(Param (LabelRef Local "main")), Param (LabelRef Local "main"),
(Param (LabelRef Global "foo")), Param (LabelRef Global "foo"),
(Param (Integer 10)), Param (Integer 10),
(Param (Integer 11)), Param (Integer 11),
(Param (LabelRef Local "bar")), Param (LabelRef Local "bar"),
(Param (Integer 20)) Param (Integer 20)
]) ])
) (length input) ) (length input)
parseInstr input `shouldBe` expected parseInstr input `shouldBe` expected
it "supports non-truncated input" $ do it "supports non-truncated input" $ do
let input = [T.Operator Push let input = [T.Operator Push
, T.Ampersand, T.Identifier "program" , T.Ampersand, T.Identifier "program"
@@ -196,26 +189,26 @@ spec = do
, T.Ampersand, T.Identifier "bar" , T.Ampersand, T.Identifier "bar"
, T.IntLiteral 20 -- this is the last param, so we're going to stop here (13 tokens so far) , T.IntLiteral 20 -- this is the last param, so we're going to stop here (13 tokens so far)
, T.Operator Call , T.Operator Call
, T.Ampersand, T.Identifier "program" , T.Ampersand, T.Identifier "program"
] ]
let expected = success (Instruction let expected = success (Instruction
(Operator Push) (Operator Push)
(Params [ (Params [
(Param (LabelRef Global "program")), Param (LabelRef Global "program"),
(Param (Integer 4)), Param (Integer 4),
(Param (LabelRef Global "main")), Param (LabelRef Global "main"),
(Param (LabelRef Local "foo")), Param (LabelRef Local "foo"),
(Param (Integer 10)), Param (Integer 10),
(Param (Integer 11)), Param (Integer 11),
(Param (LabelRef Global "bar")), Param (LabelRef Global "bar"),
(Param (Integer 20)) Param (Integer 20)
]) ])
) 14 ) 14
parseInstr input `shouldBe` expected parseInstr input `shouldBe` expected
it "supports empty input" $ it "supports empty input" $
parseInstr [] `shouldBe` Nothing parseInstr [] `shouldBe` Nothing
describe "parseLine" $ do describe "parseLine" $ do
it "supports label definition and operator in the same line" $ do it "supports label definition and operator in the same line" $ do
let input = [T.Dot, T.Identifier "main", T.Colon, T.Operator Call, T.Ampersand, T.Identifier "program"] let input = [T.Dot, T.Identifier "main", T.Colon, T.Operator Call, T.Ampersand, T.Identifier "program"]
let expected = success (Line let expected = success (Line
@@ -223,7 +216,7 @@ spec = do
(Instruction (Instruction
(Operator Call) (Operator Call)
(Params [ (Params [
(Param (LabelRef Global "program")) Param (LabelRef Global "program")
]) ])
) )
) (length input) ) (length input)
@@ -231,10 +224,10 @@ spec = do
it "supports line with just label definition" $ do it "supports line with just label definition" $ do
let input = [T.Identifier "main", T.Colon] let input = [T.Identifier "main", T.Colon]
let expected = success (Line let expected = success (Line
(LabelDef Global "main") (LabelDef Global "main")
Empty Empty
) (length input) ) (length input)
parseLine input `shouldBe` expected parseLine input `shouldBe` expected
it "supports line with just operator" $ do it "supports line with just operator" $ do
let input = [T.Operator Call, T.Ampersand, T.Dot, T.Identifier "program"] let input = [T.Operator Call, T.Ampersand, T.Dot, T.Identifier "program"]
let expected = success (Line let expected = success (Line
@@ -242,7 +235,7 @@ spec = do
(Instruction (Instruction
(Operator Call) (Operator Call)
(Params [ (Params [
(Param (LabelRef Local "program")) Param (LabelRef Local "program")
]) ])
) )
) (length input) ) (length input)
@@ -254,117 +247,117 @@ spec = do
(Instruction (Instruction
(Operator Call) (Operator Call)
(Params [ (Params [
(Param (LabelRef Global "program")) Param (LabelRef Global "program")
]) ])
) )
) 5 ) 5
parseLine input `shouldBe` expected parseLine input `shouldBe` expected
it "parses empty input" $ it "parses empty input" $
parseLine [] `shouldBe` Nothing parseLine [] `shouldBe` Nothing
describe "mapAST" $ do describe "mapAST" $ do
it "returns mapped AST if wrapped parser succeeded" $ do it "returns mapped AST if wrapped parser succeeded" $ do
let astMapper ast = Param ast let astMapper = Param
let parser = const $ success Colon 1 let parser = const $ success Colon 1
let input = [T.StringLiteral "Some not important input"] let input = [T.StringLiteral "Some not important input"]
mapAST parser astMapper input `shouldBe` success (Param Colon) 1 mapAST parser astMapper input `shouldBe` success (Param Colon) 1
it "results Nothing when wrapped parser failed" $ do it "results Nothing when wrapped parser failed" $ do
let astMapper ast = Param ast let astMapper = Param
let parser = const Nothing let parser = const Nothing
let input = [T.StringLiteral "Some not important input"] let input = [T.StringLiteral "Some not important input"]
mapAST parser astMapper input `shouldBe` Nothing mapAST parser astMapper input `shouldBe` Nothing
it "supports empty input irrespective of wrapped parser" $ do it "supports empty input irrespective of wrapped parser" $ do
let astMapper ast = Param ast let astMapper = Param
let parser = const $ success Colon 1 let parser = const $ success Colon 1
let input = [] let input = []
mapAST parser astMapper input `shouldBe` Nothing mapAST parser astMapper input `shouldBe` Nothing
describe "parseOptionally" $ do describe "parseOptionally" $ do
it "returns parsed AST if wrapped parser succeeded" $ do it "returns parsed AST if wrapped parser succeeded" $ do
let parser = const $ success Ampersand 1 let parser = const $ success Ampersand 1
let input = [T.StringLiteral "Some not important input"] let input = [T.StringLiteral "Some not important input"]
parseOptionally parser input `shouldBe` success Ampersand 1 parseOptionally parser input `shouldBe` success Ampersand 1
it "returns Empty if wrapped parser failed" $ do it "returns Empty if wrapped parser failed" $ do
let parser = const $ Nothing let parser = const Nothing
let input = [T.StringLiteral "Some not important input"] let input = [T.StringLiteral "Some not important input"]
parseOptionally parser input `shouldBe` success Empty 0 parseOptionally parser input `shouldBe` success Empty 0
it "supports empty input irrespective of wrapped parser" $ do it "supports empty input irrespective of wrapped parser" $ do
let parser = const $ Nothing let parser = const Nothing
let input = [] let input = []
parseOptionally parser input `shouldBe` success Empty 0 parseOptionally parser input `shouldBe` success Empty 0
describe "parseMany" $ do describe "parseMany" $ do
it "parses many occurrences on truncated input" $ do it "parses many occurrences on truncated input" $ do
let colonParser (T.Colon:_) = success Colon 1 let colonParser (T.Colon:_) = success Colon 1
colonParser _ = Nothing colonParser _ = Nothing
let combiner = Params let combiner = Params
let input = [T.Colon, T.Colon, T.Colon] let input = [T.Colon, T.Colon, T.Colon]
parseMany colonParser combiner input `shouldBe` success (Params [Colon, Colon, Colon]) 3 parseMany colonParser combiner input `shouldBe` success (Params [Colon, Colon, Colon]) 3
it "parses single occurence on truncated input" $ do it "parses single occurence on truncated input" $ do
let colonParser (T.Colon:_) = success Colon 1 let colonParser (T.Colon:_) = success Colon 1
colonParser _ = Nothing colonParser _ = Nothing
let combiner = Params let combiner = Params
let input = [T.Colon] let input = [T.Colon]
parseMany colonParser combiner input `shouldBe` success (Params [Colon]) 1 parseMany colonParser combiner input `shouldBe` success (Params [Colon]) 1
it "parses many occurrences on non-truncated input" $ do it "parses many occurrences on non-truncated input" $ do
let colonParser (T.Colon:_) = success Colon 1 let colonParser (T.Colon:_) = success Colon 1
colonParser _ = Nothing colonParser _ = Nothing
let combiner = Params let combiner = Params
let input = [T.Colon, T.Colon, T.Colon, T.Ampersand] let input = [T.Colon, T.Colon, T.Colon, T.Ampersand]
parseMany colonParser combiner input `shouldBe` success (Params [Colon, Colon, Colon]) 3 parseMany colonParser combiner input `shouldBe` success (Params [Colon, Colon, Colon]) 3
it "parses single occurence on non-truncated input" $ do it "parses single occurence on non-truncated input" $ do
let colonParser (T.Colon:_) = success Colon 1 let colonParser (T.Colon:_) = success Colon 1
colonParser _ = Nothing colonParser _ = Nothing
let combiner = Params let combiner = Params
let input = [T.Colon, T.Ampersand] let input = [T.Colon, T.Ampersand]
parseMany colonParser combiner input `shouldBe` success (Params [Colon]) 1 parseMany colonParser combiner input `shouldBe` success (Params [Colon]) 1
it "rejects input if current token is not parseable" $ do it "rejects input if current token is not parseable" $ do
let colonParser (T.Colon:_) = success Colon 1 let colonParser (T.Colon:_) = success Colon 1
colonParser _ = Nothing colonParser _ = Nothing
let combiner = Params let combiner = Params
let input = [T.Ampersand, T.Colon, T.Colon, T.Colon] let input = [T.Ampersand, T.Colon, T.Colon, T.Colon]
parseMany colonParser combiner input `shouldBe` Nothing parseMany colonParser combiner input `shouldBe` Nothing
it "supports empty input" $ do it "supports empty input" $ do
let colonParser (T.Colon:_) = success Colon 1 let colonParser (T.Colon:_) = success Colon 1
colonParser _ = Nothing colonParser _ = Nothing
let combiner = Params let combiner = Params
let input = [] let input = []
parseMany colonParser combiner input `shouldBe` Nothing parseMany colonParser combiner input `shouldBe` Nothing
describe "parseMany0" $ do describe "parseMany0" $ do
it "parses many occurrences on truncated input" $ do it "parses many occurrences on truncated input" $ do
let colonParser (T.Colon:_) = success Colon 1 let colonParser (T.Colon:_) = success Colon 1
colonParser _ = Nothing colonParser _ = Nothing
let combiner = Params let combiner = Params
let input = [T.Colon, T.Colon, T.Colon] let input = [T.Colon, T.Colon, T.Colon]
parseMany0 colonParser combiner input `shouldBe` success (Params [Colon, Colon, Colon]) 3 parseMany0 colonParser combiner input `shouldBe` success (Params [Colon, Colon, Colon]) 3
it "parses single occurence on truncated input" $ do it "parses single occurence on truncated input" $ do
let colonParser (T.Colon:_) = success Colon 1 let colonParser (T.Colon:_) = success Colon 1
colonParser _ = Nothing colonParser _ = Nothing
let combiner = Params let combiner = Params
let input = [T.Colon] let input = [T.Colon]
parseMany0 colonParser combiner input `shouldBe` success (Params [Colon]) 1 parseMany0 colonParser combiner input `shouldBe` success (Params [Colon]) 1
it "parses many occurrences on non-truncated input" $ do it "parses many occurrences on non-truncated input" $ do
let colonParser (T.Colon:_) = success Colon 1 let colonParser (T.Colon:_) = success Colon 1
colonParser _ = Nothing colonParser _ = Nothing
let combiner = Params let combiner = Params
let input = [T.Colon, T.Colon, T.Colon, T.Ampersand] let input = [T.Colon, T.Colon, T.Colon, T.Ampersand]
parseMany0 colonParser combiner input `shouldBe` success (Params [Colon, Colon, Colon]) 3 parseMany0 colonParser combiner input `shouldBe` success (Params [Colon, Colon, Colon]) 3
it "parses single occurence on non-truncated input" $ do it "parses single occurence on non-truncated input" $ do
let colonParser (T.Colon:_) = success Colon 1 let colonParser (T.Colon:_) = success Colon 1
colonParser _ = Nothing colonParser _ = Nothing
let combiner = Params let combiner = Params
let input = [T.Colon, T.Ampersand] let input = [T.Colon, T.Ampersand]
parseMany0 colonParser combiner input `shouldBe` success (Params [Colon]) 1 parseMany0 colonParser combiner input `shouldBe` success (Params [Colon]) 1
it "accepts input even though current token is not parseable" $ do it "accepts input even though current token is not parseable" $ do
let colonParser (T.Colon:_) = success Colon 1 let colonParser (T.Colon:_) = success Colon 1
colonParser _ = Nothing colonParser _ = Nothing
let combiner = Params let combiner = Params
let input = [T.Ampersand, T.Colon, T.Colon, T.Colon] let input = [T.Ampersand, T.Colon, T.Colon, T.Colon]
parseMany0 colonParser combiner input `shouldBe` success Empty 0 parseMany0 colonParser combiner input `shouldBe` success Empty 0
it "supports empty input" $ do it "supports empty input" $ do
let colonParser (T.Colon:_) = success Colon 1 let colonParser (T.Colon:_) = success Colon 1
colonParser _ = Nothing colonParser _ = Nothing
let combiner = Params let combiner = Params
let input = [] let input = []
parseMany0 colonParser combiner input `shouldBe` success Empty 0 parseMany0 colonParser combiner input `shouldBe` success Empty 0
@@ -375,7 +368,7 @@ spec = do
, Nothing , Nothing
, Nothing , Nothing
, Nothing , Nothing
, Nothing , Nothing
] ]
let input = [T.StringLiteral "some not important input"] let input = [T.StringLiteral "some not important input"]
parseAny parsers input `shouldBe` success Ampersand 1 parseAny parsers input `shouldBe` success Ampersand 1
@@ -384,7 +377,7 @@ spec = do
, Nothing , Nothing
, success (Integer 4) 1 , success (Integer 4) 1
, Nothing , Nothing
, Nothing , Nothing
, success (LabelDef Local "not me") 2 , success (LabelDef Local "not me") 2
, Nothing , Nothing
, success (Instruction (Operator Push) Empty) 1 , success (Instruction (Operator Push) Empty) 1
@@ -395,14 +388,14 @@ spec = do
, success Colon 1 , success Colon 1
, Nothing , Nothing
] ]
let input = [T.StringLiteral "some not important input"] let input = [T.StringLiteral "some not important input"]
parseAny parsers input `shouldBe` success (Integer 4) 1 parseAny parsers input `shouldBe` success (Integer 4) 1
it "returns Nothing if no one of the parsers matches the input" $ do it "returns Nothing if no one of the parsers matches the input" $ do
let parsers = map const (take 4 $ repeat $ Nothing) let parsers = replicate 4 (const Nothing)
let input = [T.StringLiteral "some not important input"] let input = [T.StringLiteral "some not important input"]
parseAny parsers input `shouldBe` Nothing parseAny parsers input `shouldBe` Nothing
it "always returns Nothing if no parsers are defined" $ do it "always returns Nothing if no parsers are defined" $ do
let input = [T.StringLiteral "some not important input"] let input = [T.StringLiteral "some not important input"]
parseAny [] input `shouldBe` Nothing parseAny [] input `shouldBe` Nothing
it "supports empty input irrespective of wrapped parsers" $ do it "supports empty input irrespective of wrapped parsers" $ do
let parsers = map const [ success (Integer 4) 1 let parsers = map const [ success (Integer 4) 1
@@ -413,45 +406,45 @@ spec = do
, success Colon 1 , success Colon 1
] ]
let input = [] let input = []
parseAny parsers input `shouldBe` Nothing parseAny parsers input `shouldBe` Nothing
describe "parseSeq" $ do describe "parseSeq" $ do
it "parses truncated input" $ do it "parses truncated input" $ do
let colonParser (T.Colon:_) = success Colon 1 let colonParser (T.Colon:_) = success Colon 1
colonParser _ = Nothing colonParser _ = Nothing
let ampersandParser (T.Ampersand:_) = success Ampersand 1 let ampersandParser (T.Ampersand:_) = success Ampersand 1
ampersandParser _ = Nothing ampersandParser _ = Nothing
let combiner = Params let combiner = Params
let pattern = [colonParser, ampersandParser] let pattern = [colonParser, ampersandParser]
let input = [T.Colon, T.Ampersand] let input = [T.Colon, T.Ampersand]
parseSeq pattern combiner input `shouldBe` success (Params [Colon, Ampersand]) 2 parseSeq pattern combiner input `shouldBe` success (Params [Colon, Ampersand]) 2
it "parses non-truncated input" $ do it "parses non-truncated input" $ do
let colonParser (T.Colon:_) = success Colon 1 let colonParser (T.Colon:_) = success Colon 1
colonParser _ = Nothing colonParser _ = Nothing
let ampersandParser (T.Ampersand:_) = success Ampersand 1 let ampersandParser (T.Ampersand:_) = success Ampersand 1
ampersandParser _ = Nothing ampersandParser _ = Nothing
let combiner = Params let combiner = Params
let pattern = [colonParser, ampersandParser] let pattern = [colonParser, ampersandParser]
let input = [T.Colon, T.Ampersand, T.Colon] let input = [T.Colon, T.Ampersand, T.Colon]
parseSeq pattern combiner input `shouldBe` success (Params [Colon, Ampersand]) 2 parseSeq pattern combiner input `shouldBe` success (Params [Colon, Ampersand]) 2
it "rejects incomplete pattern" $ do it "rejects incomplete pattern" $ do
let colonParser (T.Colon:_) = success Colon 1 let colonParser (T.Colon:_) = success Colon 1
colonParser _ = Nothing colonParser _ = Nothing
let ampersandParser (T.Ampersand:_) = success Ampersand 1 let ampersandParser (T.Ampersand:_) = success Ampersand 1
ampersandParser _ = Nothing ampersandParser _ = Nothing
let combiner = Params let combiner = Params
let pattern = [colonParser, ampersandParser] let pattern = [colonParser, ampersandParser]
let input = [T.Colon] let input = [T.Colon]
parseSeq pattern combiner input `shouldBe` Nothing parseSeq pattern combiner input `shouldBe` Nothing
it "rejects non-matching input" $ do it "rejects non-matching input" $ do
let colonParser (T.Colon:_) = success Colon 1 let colonParser (T.Colon:_) = success Colon 1
colonParser _ = Nothing colonParser _ = Nothing
let ampersandParser (T.Ampersand:_) = success Ampersand 1 let ampersandParser (T.Ampersand:_) = success Ampersand 1
ampersandParser _ = Nothing ampersandParser _ = Nothing
let combiner = Params let combiner = Params
let pattern = [colonParser, ampersandParser] let pattern = [colonParser, ampersandParser]
let input = [T.Ampersand, T.Colon] let input = [T.Ampersand, T.Colon]
parseSeq pattern combiner input `shouldBe` Nothing parseSeq pattern combiner input `shouldBe` Nothing
it "supports empty input irrespective of wrapped parsers" $ do it "supports empty input irrespective of wrapped parsers" $ do
let pattern = map const [ success (Integer 4) 1 let pattern = map const [ success (Integer 4) 1
, success (LabelDef Global "not me") 2 , success (LabelDef Global "not me") 2
@@ -471,11 +464,11 @@ spec = do
it "returns Nothing if there are tokens left to be consumed, even though the wrapped parser succeeded to parse" $ do it "returns Nothing if there are tokens left to be consumed, even though the wrapped parser succeeded to parse" $ do
let parser = const $ success Colon 1 let parser = const $ success Colon 1
let input = [T.Colon, T.Ampersand] let input = [T.Colon, T.Ampersand]
assertConsumed parser input `shouldBe` Nothing assertConsumed parser input `shouldBe` Nothing
it "supports empty input" $ do it "supports empty input" $ do
let parser = const $ success Colon 1 let parser = const $ success Colon 1
let input = [] let input = []
assertConsumed parser input `shouldBe` Nothing assertConsumed parser input `shouldBe` Nothing
describe "parse" $ do describe "parse" $ do
it "parses empty input" $ do it "parses empty input" $ do
@@ -486,11 +479,11 @@ spec = do
let input = "add1_2: push 1\npush 2\nadd" let input = "add1_2: push 1\npush 2\nadd"
let (Right tokens) = T.tokenize input let (Right tokens) = T.tokenize input
-- Labels: Operations: Params: -- Labels: Operations: Params:
let expected = Program [ (Line (LabelDef Global "add1_2") (Instruction (Operator Push) (Params [Param $ Integer 1]))) let expected = Program [ Line (LabelDef Global "add1_2") (Instruction (Operator Push) (Params [Param $ Integer 1]))
, (Line Empty (Instruction (Operator Push) (Params [Param $ Integer 2]))) , Line Empty (Instruction (Operator Push) (Params [Param $ Integer 2]))
, (Line Empty (Instruction (Operator Add) Empty)) , Line Empty (Instruction (Operator Add) Empty)
] ]
parse tokens `shouldBe` (Right $ expected :: Either String AST) parse tokens `shouldBe` (Right expected :: Either String AST)
it "rejects multiple instructions in single line" $ do it "rejects multiple instructions in single line" $ do
let input = "push 1 add" let input = "push 1 add"
let (Right tokens) = T.tokenize input let (Right tokens) = T.tokenize input
@@ -500,9 +493,9 @@ spec = do
let (Right tokens) = T.tokenize input let (Right tokens) = T.tokenize input
parse tokens `shouldBe` (Left "Parse error(s):\n[Identifier \"label1\",Colon,Identifier \"label2\",Colon]" :: Either String AST) parse tokens `shouldBe` (Left "Parse error(s):\n[Identifier \"label1\",Colon,Identifier \"label2\",Colon]" :: Either String AST)
it "rejects instruction followed by a label definition" $ do it "rejects instruction followed by a label definition" $ do
let input = "pop label:" let input = "pop label:"
let (Right tokens) = T.tokenize input let (Right tokens) = T.tokenize input
parse tokens `shouldBe` (Left "Parse error(s):\n[Operator Pop,Identifier \"label\",Colon]" :: Either String AST) parse tokens `shouldBe` (Left "Parse error(s):\n[Operator Pop,Identifier \"label\",Colon]" :: Either String AST)
it "rejects orphaned identifiers" $ do it "rejects orphaned identifiers" $ do
let inputs = ["id", "push id", "main: id", "id main:"] let inputs = ["id", "push id", "main: id", "id main:"]
let tokens = map ((\(Right t) -> t) . T.tokenize) inputs let tokens = map ((\(Right t) -> t) . T.tokenize) inputs
@@ -521,7 +514,7 @@ spec = do
, "Parse error(s):\n[Ampersand,IntLiteral 4]" , "Parse error(s):\n[Ampersand,IntLiteral 4]"
, "Parse error(s):\n[Identifier \"label\",IntLiteral 5,Colon]" , "Parse error(s):\n[Identifier \"label\",IntLiteral 5,Colon]"
] :: [Either String AST] ] :: [Either String AST]
map parse tokens `shouldBe` expected map parse tokens `shouldBe` expected
it "parses example #1" $ do it "parses example #1" $ do
let input = "main: ; here we define some main label\n\ let input = "main: ; here we define some main label\n\
\ push 7 ; we push 7 to the stack\n\ \ push 7 ; we push 7 to the stack\n\
@@ -533,12 +526,12 @@ spec = do
\ ret" \ ret"
let (Right tokens) = T.tokenize input let (Right tokens) = T.tokenize input
-- Labels: Operations: Params: -- Labels: Operations: Params:
let expected = Program [ (Line (LabelDef Global "main") Empty) let expected = Program [ Line (LabelDef Global "main") Empty
, (Line Empty (Instruction (Operator Push) (Params [Param $ Integer 7]))) , Line Empty (Instruction (Operator Push) (Params [Param $ Integer 7]))
, (Line Empty (Instruction (Operator Push) (Params [Param $ Integer 4]))) , Line Empty (Instruction (Operator Push) (Params [Param $ Integer 4]))
, (Line Empty (Instruction (Operator Call) (Params [Param $ LabelRef Global "sum"]))) , Line Empty (Instruction (Operator Call) (Params [Param $ LabelRef Global "sum"]))
, (Line Empty (Instruction (Operator Halt) Empty)) , Line Empty (Instruction (Operator Halt) Empty)
, (Line (LabelDef Global "sum") (Instruction (Operator Add) Empty)) , Line (LabelDef Global "sum") (Instruction (Operator Add) Empty)
, (Line Empty (Instruction (Operator Ret) Empty)) , Line Empty (Instruction (Operator Ret) Empty)
] ]
parse tokens `shouldBe` (Right $ expected :: Either String AST) parse tokens `shouldBe` (Right expected :: Either String AST)

158
test/Assembler/TokenizerSpec.hs
View File

@@ -12,7 +12,7 @@ success token consumed = Just $ TokenizeResult token consumed
spec :: Spec spec :: Spec
spec = do spec = do
describe "keywordTokenizer" $ do describe "keywordTokenizer" $ do
it "supports truncated input" $ it "supports truncated input" $
keywordTokenizer True "hey" NewLine "hey" `shouldBe` success NewLine 3 keywordTokenizer True "hey" NewLine "hey" `shouldBe` success NewLine 3
it "supports non-truncated input" $ it "supports non-truncated input" $
@@ -20,12 +20,12 @@ spec = do
it "supports case sensitivity" $ it "supports case sensitivity" $
keywordTokenizer True "hey" NewLine "heYjude" `shouldBe` Nothing keywordTokenizer True "hey" NewLine "heYjude" `shouldBe` Nothing
it "supports case insensitivity" $ it "supports case insensitivity" $
keywordTokenizer False "hey" NewLine "heYjude" `shouldBe` success NewLine 3 keywordTokenizer False "hey" NewLine "heYjude" `shouldBe` success NewLine 3
it "returns correct token" $ it "returns correct token" $
keywordTokenizer True "hey" Colon "heyjude" `shouldBe` success Colon 3 keywordTokenizer True "hey" Colon "heyjude" `shouldBe` success Colon 3
it "returns Nothing if input does not match" $ it "returns Nothing if input does not match" $
keywordTokenizer True "hey" Colon "xheyjude" `shouldBe` Nothing keywordTokenizer True "hey" Colon "xheyjude" `shouldBe` Nothing
it "supports empty input" $ it "supports empty input" $
keywordTokenizer True "hey" Colon "" `shouldBe` Nothing keywordTokenizer True "hey" Colon "" `shouldBe` Nothing
describe "operatorTokenizer" $ do describe "operatorTokenizer" $ do
@@ -35,7 +35,7 @@ spec = do
operatorTokenizer Pop "pops" `shouldBe` success (Operator Pop) 3 operatorTokenizer Pop "pops" `shouldBe` success (Operator Pop) 3
it "returns Nothing if input does not match" $ it "returns Nothing if input does not match" $
operatorTokenizer Pop "poop" `shouldBe` Nothing operatorTokenizer Pop "poop" `shouldBe` Nothing
it "supports empty input" $ it "supports empty input" $
operatorTokenizer Call "" `shouldBe` Nothing operatorTokenizer Call "" `shouldBe` Nothing
describe "tokenizeOperators" $ do describe "tokenizeOperators" $ do
@@ -53,7 +53,7 @@ spec = do
map tokenizeOperators input `shouldBe` expected map tokenizeOperators input `shouldBe` expected
it "rejects other input" $ it "rejects other input" $
tokenizeOperators "some unsupported input" `shouldBe` Nothing tokenizeOperators "some unsupported input" `shouldBe` Nothing
it "supports empty input" $ it "supports empty input" $
tokenizeOperators "" `shouldBe` Nothing tokenizeOperators "" `shouldBe` Nothing
describe "tokenizeIdentifier" $ do describe "tokenizeIdentifier" $ do
@@ -62,12 +62,12 @@ spec = do
it "parses correct identifier with numbers" $ it "parses correct identifier with numbers" $
tokenizeIdentifier "someId14" `shouldBe` success (Identifier "someId14") 8 tokenizeIdentifier "someId14" `shouldBe` success (Identifier "someId14") 8
it "parses correct identifier with underscores" $ it "parses correct identifier with underscores" $
tokenizeIdentifier "some_Id" `shouldBe` success (Identifier "some_Id") 7 tokenizeIdentifier "some_Id" `shouldBe` success (Identifier "some_Id") 7
it "disallows to start identifier with underscore" $ it "disallows to start identifier with underscore" $
tokenizeIdentifier "_someId" `shouldBe` Nothing tokenizeIdentifier "_someId" `shouldBe` Nothing
it "disallows to start identifier with digit" $ it "disallows to start identifier with digit" $
tokenizeIdentifier "5someId" `shouldBe` Nothing tokenizeIdentifier "5someId" `shouldBe` Nothing
it "supports empty input" $ it "supports empty input" $
tokenizeIdentifier "" `shouldBe` Nothing tokenizeIdentifier "" `shouldBe` Nothing
describe "tokenizeWhitespace" $ do describe "tokenizeWhitespace" $ do
@@ -80,12 +80,12 @@ spec = do
it "parses CR" $ it "parses CR" $
tokenizeWhitespace "\r" `shouldBe` success WhiteSpace 1 tokenizeWhitespace "\r" `shouldBe` success WhiteSpace 1
it "rejects non-whitespace chars" $ do it "rejects non-whitespace chars" $ do
let input = map (\x -> [x]) $ ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] let input = map (: []) $ ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9']
let expected = take (length input) . repeat $ Nothing let expected = replicate (length input) Nothing
map tokenizeWhitespace input `shouldBe` expected map tokenizeWhitespace input `shouldBe` expected
it "supports empty input" $ it "supports empty input" $
tokenizeIdentifier "" `shouldBe` Nothing tokenizeIdentifier "" `shouldBe` Nothing
describe "tokenizeDecimal" $ do describe "tokenizeDecimal" $ do
it "parses numbers from 0 to 65535" $ do it "parses numbers from 0 to 65535" $ do
let nums = [0 .. 65535] let nums = [0 .. 65535]
@@ -95,34 +95,34 @@ spec = do
it "does not support negative numbers" $ do it "does not support negative numbers" $ do
let nums = [-1, -2 .. -65535] :: [Integer] let nums = [-1, -2 .. -65535] :: [Integer]
let input = map show nums let input = map show nums
let expected = take (length nums) . repeat $ Nothing let expected = replicate (length nums) Nothing
map tokenizeDecimal input `shouldBe` expected map tokenizeDecimal input `shouldBe` expected
it "rejects other input" $ it "rejects other input" $
tokenizeDecimal "some unsupported input" `shouldBe` Nothing tokenizeDecimal "some unsupported input" `shouldBe` Nothing
it "supports empty input" $ it "supports empty input" $
tokenizeDecimal "" `shouldBe` Nothing tokenizeDecimal "" `shouldBe` Nothing
describe "tokenizeHex" $ do describe "tokenizeHex" $ do
it "parses numbers from 0x0 to 0xFFFF" $ do it "parses numbers from 0x0 to 0xFFFF" $ do
let nums = [0 .. 0xFFFF] let nums = [0 .. 0xFFFF]
let input = map (("0x"++) . (flip showHex "")) nums let input = map (("0x"++) . flip showHex "") nums
let expected = map (\n -> success (IntLiteral n) (length . ("0x"++) . (flip showHex "") $ n)) nums let expected = map (\n -> success (IntLiteral n) (length . ("0x"++) . flip showHex "" $ n)) nums
map tokenizeHex input `shouldBe` expected map tokenizeHex input `shouldBe` expected
it "does not support negative numbers" $ do it "does not support negative numbers" $ do
let nums = [0 .. 0xFFFF] :: [Integer] let nums = [0 .. 0xFFFF] :: [Integer]
let input = map (("-0x"++) . (flip showHex "")) nums let input = map (("-0x"++) . flip showHex "") nums
let expected = take (length nums) . repeat $ Nothing let expected = replicate (length nums) Nothing
map tokenizeHex input `shouldBe` expected map tokenizeHex input `shouldBe` expected
it "accepts left-padded number" $ it "accepts left-padded number" $
tokenizeHex "0x0010" `shouldBe` success (IntLiteral 16) 6 tokenizeHex "0x0010" `shouldBe` success (IntLiteral 16) 6
it "rejects other input" $ it "rejects other input" $
tokenizeHex "some unsupported input" `shouldBe` Nothing tokenizeHex "some unsupported input" `shouldBe` Nothing
it "rejects '0'" $ it "rejects '0'" $
tokenizeHex "0" `shouldBe` Nothing tokenizeHex "0" `shouldBe` Nothing
it "rejects '0x'" $ it "rejects '0x'" $
tokenizeHex "0x" `shouldBe` Nothing tokenizeHex "0x" `shouldBe` Nothing
it "supports empty input" $ it "supports empty input" $
tokenizeHex "" `shouldBe` Nothing tokenizeHex "" `shouldBe` Nothing
describe "tokenizeChar" $ do describe "tokenizeChar" $ do
it "parses letters literals" $ do it "parses letters literals" $ do
@@ -134,13 +134,13 @@ spec = do
let chars = ['0' .. '9'] let chars = ['0' .. '9']
let input = map (\c -> "'" ++ [c] ++ "'") chars let input = map (\c -> "'" ++ [c] ++ "'") chars
let expected = map (\c -> success (IntLiteral (ord c)) 3) chars let expected = map (\c -> success (IntLiteral (ord c)) 3) chars
map tokenizeChar input `shouldBe` expected map tokenizeChar input `shouldBe` expected
it "parses regular symbols literals" $ do it "parses regular symbols literals" $ do
let chars = "!@#$%^&*()_+-=[]{};:|,/?<>\"" let chars = "!@#$%^&*()_+-=[]{};:|,/?<>\""
let input = map (\c -> "'" ++ [c] ++ "'") chars let input = map (\c -> "'" ++ [c] ++ "'") chars
let expected = map (\c -> success (IntLiteral (ord c)) 3) chars let expected = map (\c -> success (IntLiteral (ord c)) 3) chars
map tokenizeChar input `shouldBe` expected map tokenizeChar input `shouldBe` expected
it "parses escape sequences literals" $ do it "parses escape sequences literals" $ do
let input = [ "'\\n'" let input = [ "'\\n'"
, "'\\t'" , "'\\t'"
, "'\\v'" , "'\\v'"
@@ -162,7 +162,7 @@ spec = do
tokenizeChar "'ab'" `shouldBe` Nothing tokenizeChar "'ab'" `shouldBe` Nothing
it "rejects non-closed char literals" $ it "rejects non-closed char literals" $
tokenizeChar "'a" `shouldBe` Nothing tokenizeChar "'a" `shouldBe` Nothing
it "rejects invalid escape sequences" $ it "rejects invalid escape sequences" $
tokenizeChar "'\\x'" `shouldBe` Nothing tokenizeChar "'\\x'" `shouldBe` Nothing
it "rejects empty quotes" $ it "rejects empty quotes" $
tokenizeChar "''" `shouldBe` Nothing tokenizeChar "''" `shouldBe` Nothing
@@ -185,9 +185,8 @@ spec = do
let str = "!@2#$%9^&*(1)_s+2-=[2h6sh]t{};:'e|<>,./?" let str = "!@2#$%9^&*(1)_s+2-=[2h6sh]t{};:'e|<>,./?"
let len = length str + 2 let len = length str + 2
let input = "\"" ++ str ++ "\"" let input = "\"" ++ str ++ "\""
tokenizeString input `shouldBe` success (StringLiteral str) len tokenizeString input `shouldBe` success (StringLiteral str) len
it "supports escape sequences literals" $ do it "supports escape sequences literals" $ pendingWith "We need probably to fix tokenizeString since the following test fails"
pendingWith "We need probably to fix tokenizeString since the following test fails"
-- TODO: -- TODO:
-- let str = "\\n\\t\\v\\b\\r\\f\\a\\\\\\\"\\0" -- let str = "\\n\\t\\v\\b\\r\\f\\a\\\\\\\"\\0"
-- let len = length str + 2 -- let len = length str + 2
@@ -207,18 +206,18 @@ spec = do
it "rejects multilined strings" $ it "rejects multilined strings" $
tokenizeString "\"first line\nsecond line\"" `shouldBe` Nothing tokenizeString "\"first line\nsecond line\"" `shouldBe` Nothing
it "supports empty input" $ it "supports empty input" $
tokenizeString "" `shouldBe` Nothing tokenizeString "" `shouldBe` Nothing
describe "tokenizeComment" $ do describe "tokenizeComment" $ do
it "properly consumes comment" $ it "properly consumes comment" $
tokenizeComment ";some comment\n" `shouldBe` success (Comment "some comment") 13 tokenizeComment ";some comment\n" `shouldBe` success (Comment "some comment") 13
it "properly consumes comment with whitespace padding" $ it "properly consumes comment with whitespace padding" $
tokenizeComment "; \t some comment \t \n \t" `shouldBe` success (Comment " \t some comment \t ") 22 tokenizeComment "; \t some comment \t \n \t" `shouldBe` success (Comment " \t some comment \t ") 22
it "does not treat the input as a comment if it does not start with semicolon" $ it "does not treat the input as a comment if it does not start with semicolon" $
tokenizeComment "some not valid comment\n" `shouldBe` Nothing tokenizeComment "some not valid comment\n" `shouldBe` Nothing
it "expands the comment till the end of the line" $ it "expands the comment till the end of the line" $
tokenizeComment "; some comment ; push 4 push 10\nadd" `shouldBe` success (Comment " some comment ; push 4 push 10") 31 tokenizeComment "; some comment ; push 4 push 10\nadd" `shouldBe` success (Comment " some comment ; push 4 push 10") 31
it "parses the comment at the end of the input" $ it "parses the comment at the end of the input" $
tokenizeComment "; some comment " `shouldBe` success (Comment " some comment ") 15 tokenizeComment "; some comment " `shouldBe` success (Comment " some comment ") 15
it "supports empty input" $ it "supports empty input" $
tokenizeComment "" `shouldBe` Nothing tokenizeComment "" `shouldBe` Nothing
@@ -241,7 +240,7 @@ spec = do
it "does not produce any token when the space is present instead" $ do it "does not produce any token when the space is present instead" $ do
let input = "abc " let input = "abc "
let tokenizer _ = success Colon 3 let tokenizer _ = success Colon 3
sepTokenizer ('-'==) tokenizer input `shouldBe` Nothing sepTokenizer ('-'==) tokenizer input `shouldBe` Nothing
it "does not change the number of consumed chars even though it's checking the separator presence" $ do it "does not change the number of consumed chars even though it's checking the separator presence" $ do
let input = "abc-" let input = "abc-"
let expected = success Colon 3 let expected = success Colon 3
@@ -251,24 +250,24 @@ spec = do
it "supports empty input irrespective of wrapped tokenizer" $ do it "supports empty input irrespective of wrapped tokenizer" $ do
let input = "" let input = ""
let tokenizer _ = success Colon 3 -- MOCK: tokenizer returns Just even though the input is empty let tokenizer _ = success Colon 3 -- MOCK: tokenizer returns Just even though the input is empty
sepTokenizer ('-'==) tokenizer input `shouldBe` Nothing sepTokenizer ('-'==) tokenizer input `shouldBe` Nothing
describe "anyTokenizer" $ do describe "anyTokenizer" $ do
it "returns the token if at least one subtokenizer produce that" $ do it "returns the token if at least one subtokenizer produce that" $ do
let values = [ success Ampersand 1 let values = [ success Ampersand 1
, Nothing , Nothing
, Nothing , Nothing
, Nothing , Nothing
, Nothing , Nothing
] ]
let t = map (\x -> (\_ -> x)) values let t = map const values
anyTokenizer t "some not important input" `shouldBe` success Ampersand 1 anyTokenizer t "some not important input" `shouldBe` success Ampersand 1
it "returns the token of the first matching subtokenizer" $ do it "returns the token of the first matching subtokenizer" $ do
let values = [ Nothing let values = [ Nothing
, Nothing , Nothing
, success (IntLiteral 4) 1 , success (IntLiteral 4) 1
, Nothing , Nothing
, Nothing , Nothing
, success (StringLiteral "not me") 8 , success (StringLiteral "not me") 8
, Nothing , Nothing
, success (StringLiteral "me neither") 12 , success (StringLiteral "me neither") 12
@@ -279,19 +278,19 @@ spec = do
, success Colon 1 , success Colon 1
, Nothing , Nothing
] ]
let t = map (\x -> (\_ -> x)) values let t = map const values
anyTokenizer t "some not important input" `shouldBe` success (IntLiteral 4) 1 anyTokenizer t "some not important input" `shouldBe` success (IntLiteral 4) 1
it "returns Nothing if no one of the tokenizers matches the input" $ do it "returns Nothing if no one of the tokenizers matches the input" $ do
let values = [ Nothing let values = [ Nothing
, Nothing , Nothing
, Nothing , Nothing
, Nothing , Nothing
, Nothing , Nothing
] ]
let t = map (\x -> (\_ -> x)) values let t = map const values
anyTokenizer t "some not important input" `shouldBe` Nothing anyTokenizer t "some not important input" `shouldBe` Nothing
it "always returns Nothing if no tokenizers are defined" $ it "always returns Nothing if no tokenizers are defined" $
anyTokenizer [] "some not important input" `shouldBe` Nothing anyTokenizer [] "some not important input" `shouldBe` Nothing
it "supports empty input irrespective of wrapped tokenizers" $ do it "supports empty input irrespective of wrapped tokenizers" $ do
let input = "" let input = ""
let values = [ success Ampersand 1 let values = [ success Ampersand 1
@@ -299,47 +298,46 @@ spec = do
, success (IntLiteral 3) 1 , success (IntLiteral 3) 1
, success (Operator Push) 4 , success (Operator Push) 4
] ]
let t = map (\x -> (\_ -> x)) values let t = map const values
anyTokenizer t input `shouldBe` Nothing anyTokenizer t input `shouldBe` Nothing
describe "tokenFilter" $ do describe "tokenFilter" $ it "filters out whitespaces and comments" $ do
it "filters out whitespaces and comments" $ do let tokens = [ Operator Push
let tokens = [ Operator Push , IntLiteral 4
, Comment "here is the identifier"
, Identifier "someId"
, WhiteSpace
, Colon
, WhiteSpace
, Ampersand
, NewLine
, WhiteSpace
, Comment "some comment"
]
let expected = [ Operator Push
, IntLiteral 4 , IntLiteral 4
, Comment "here is the identifier"
, Identifier "someId" , Identifier "someId"
, WhiteSpace
, Colon , Colon
, WhiteSpace
, Ampersand , Ampersand
, NewLine , NewLine
, WhiteSpace
, Comment "some comment"
] ]
let expected = [ Operator Push filter tokenFilter tokens `shouldBe` expected
, IntLiteral 4
, Identifier "someId"
, Colon
, Ampersand
, NewLine
]
filter tokenFilter tokens `shouldBe` expected
describe "tokenize" $ do describe "tokenize" $ do
it "treats 'pop' as a operator instead of identifier" $ it "treats 'pop' as a operator instead of identifier" $
tokenize "pop" `shouldBe` Right [Operator Pop] tokenize "pop" `shouldBe` Right [Operator Pop]
it "treats 'poop' as a identifier" $ it "treats 'poop' as a identifier" $
tokenize "poop" `shouldBe` Right [Identifier "poop"] tokenize "poop" `shouldBe` Right [Identifier "poop"]
it "treats operator as themselves instead of identifiers" $ do it "treats operator as themselves instead of identifiers" $ do
let ops = [Nop ..] let ops = [Nop ..]
let input = map show ops let input = map show ops
let expected = map (\o -> Right [Operator o]) ops let expected = map (\o -> Right [Operator o]) ops
map tokenize input `shouldBe` expected map tokenize input `shouldBe` expected
it "treats operator-like names (with 's' appended) as identifiers" $ do it "treats operator-like names (with 's' appended) as identifiers" $ do
let ops = [Nop ..] let ops = [Nop ..]
let input = map ((++"s") . show) ops let input = map ((++"s") . show) ops
let expected = map (\i-> Right [Identifier i]) input let expected = map (\i-> Right [Identifier i]) input
map tokenize input `shouldBe` expected map tokenize input `shouldBe` expected
it "treats '\n' as a newline instead of whitespace" $ it "treats '\n' as a newline instead of whitespace" $
tokenize "\n" `shouldBe` Right [NewLine] tokenize "\n" `shouldBe` Right [NewLine]
it "ignores comments" $ do it "ignores comments" $ do
@@ -355,11 +353,11 @@ spec = do
it "accepts 'main: NL" $ it "accepts 'main: NL" $
tokenize ".main: \n" `shouldBe` Right [Dot, Identifier "main", Colon, NewLine] tokenize ".main: \n" `shouldBe` Right [Dot, Identifier "main", Colon, NewLine]
it "accepts 'call &sum NL" $ it "accepts 'call &sum NL" $
tokenize "call &sum \n" `shouldBe` Right [Operator Call, Ampersand, Identifier "sum", NewLine] tokenize "call &sum \n" `shouldBe` Right [Operator Call, Ampersand, Identifier "sum", NewLine]
it "rejects '4push'" $ it "rejects '4push'" $
tokenize "4push" `shouldBe` Left "Unknown token: 4push" tokenize "4push" `shouldBe` Left "Unknown token: 4push"
it "supports empty input" $ it "supports empty input" $
tokenize "" `shouldBe` Right [] tokenize "" `shouldBe` Right []
it "interprets example #1" $ do it "interprets example #1" $ do
let input = "main: ; here we define some main label\n\ let input = "main: ; here we define some main label\n\
\ push 7 ; we push 7 to the stack\n\ \ push 7 ; we push 7 to the stack\n\
@@ -377,5 +375,5 @@ spec = do
, NewLine , NewLine
, Identifier "sum", Colon, Operator Add, NewLine , Identifier "sum", Colon, Operator Add, NewLine
, Operator Ret , Operator Ret
] ]
tokenize input `shouldBe` Right expected tokenize input `shouldBe` Right expected

118
test/VirtualMachineSpec.hs
View File

@@ -741,14 +741,14 @@ spec = do
let vm = empty { _stack = S.fromList [], _fp = 0 } let vm = empty { _stack = S.fromList [], _fp = 0 }
let input = " ret \n\ let input = " ret \n\
\ halt " \ halt "
let expected = Left "Cannot determine previous frame pointer (fp)" let expected = Left "Cannot determine frame pointer (fp) - index 0 out of frame bounds"
actual <- exec vm input actual <- exec vm input
actual `shouldBe` expected actual `shouldBe` expected
it "raises error if there is no return address on the stack (stack size is 1)" $ do it "raises error if there is no return address on the stack (stack size is 1)" $ do
let vm = empty { _stack = S.fromList [-1], _fp = 0 } let vm = empty { _stack = S.fromList [-1], _fp = 0 }
let input = " ret \n\ let input = " ret \n\
\ halt " \ halt "
let expected = Left "Cannot determine return address" let expected = Left "Cannot determine return address - index 1 out of frame bounds"
actual <- exec vm input actual <- exec vm input
actual `shouldBe` expected actual `shouldBe` expected
@@ -790,7 +790,7 @@ spec = do
it "raises error if stack is empty" $ do it "raises error if stack is empty" $ do
let input = " lda 0 \n\ let input = " lda 0 \n\
\ halt " \ halt "
let expected = Left "Index 0 out of stack bounds" let expected = Left "Cannot determine call argument - index 0 out of frame bounds"
let vm = empty { _stack = S.fromList [], _fp = 0 } let vm = empty { _stack = S.fromList [], _fp = 0 }
actual <- exec vm input actual <- exec vm input
actual `shouldBe` expected actual `shouldBe` expected
@@ -798,14 +798,14 @@ spec = do
let vm = empty { _stack = S.fromList [-1], _fp = 0 } let vm = empty { _stack = S.fromList [-1], _fp = 0 }
let input = " lda 0 \n\ let input = " lda 0 \n\
\ halt " \ halt "
let expected = Left "Index 0 out of stack bounds" let expected = Left "Cannot determine call argument - index 0 out of frame bounds"
actual <- exec vm input actual <- exec vm input
actual `shouldBe` expected actual `shouldBe` expected
it "raises error if stack contains only previous fp and return address" $ do it "raises error if stack contains only previous fp and return address" $ do
let vm = empty { _stack = S.fromList [2, -1], _fp = 0 } let vm = empty { _stack = S.fromList [2, -1], _fp = 0 }
let input = " lda 0 \n\ let input = " lda 0 \n\
\ halt " \ halt "
let expected = Left "Index 0 out of stack bounds" let expected = Left "Cannot determine call argument - index 0 out of frame bounds"
actual <- exec vm input actual <- exec vm input
actual `shouldBe` expected actual `shouldBe` expected
it "loads the first (0) argument if stack contains only previous fp, return address and single argument" $ do it "loads the first (0) argument if stack contains only previous fp, return address and single argument" $ do
@@ -819,7 +819,7 @@ spec = do
let vm = empty { _stack = S.fromList [2, -1, 3], _fp = 1 } let vm = empty { _stack = S.fromList [2, -1, 3], _fp = 1 }
let input = " lda 1 \n\ let input = " lda 1 \n\
\ halt " \ halt "
let expected = Left "Index 1 out of stack bounds" let expected = Left "Cannot determine call argument - index 1 out of frame bounds"
actual <- exec vm input actual <- exec vm input
actual `shouldBe` expected actual `shouldBe` expected
it "loads the 11th argument if it exists" $ do it "loads the 11th argument if it exists" $ do
@@ -861,109 +861,7 @@ spec = do
\ ret " \ ret "
let expected = done [25] 8 (-1) let expected = done [25] 8 (-1)
actual <- run input actual <- run input
actual `shouldBe` expected
describe "roll" $ do
it "supports stack with 5 elements" $ do
let input = " push 4 \n\
\ push 5 \n\
\ push 6 \n\
\ push 7 \n\
\ push 8 \n\
\ roll \n\
\ halt "
let expected = done [7, 6, 5, 4, 8] 11 (-1)
actual <- run input
actual `shouldBe` expected actual `shouldBe` expected
it "supports stack with 4 elements" $ do
let input = " push 4 \n\
\ push 5 \n\
\ push 6 \n\
\ push 7 \n\
\ roll \n\
\ halt "
let expected = done [6, 5, 4, 7] 9 (-1)
actual <- run input
actual `shouldBe` expected
it "supports stack with 3 elements" $ do
let input = " push 4 \n\
\ push 5 \n\
\ push 6 \n\
\ roll \n\
\ halt "
let expected = done [5, 4, 6] 7 (-1)
actual <- run input
actual `shouldBe` expected
it "supports stack with 2 elements" $ do
let input = " push 4 \n\
\ push 5 \n\
\ roll \n\
\ halt "
let expected = done [4, 5] 5 (-1)
actual <- run input
actual `shouldBe` expected
it "supports singleton stack" $ do
let input = " push 4 \n\
\ roll \n\
\ halt "
let expected = done [4] 3 (-1)
actual <- run input
actual `shouldBe` expected
it "supports empty stack" $ do
let input = " roll \n\
\ halt "
let expected = done [] 1 (-1)
actual <- run input
actual `shouldBe` expected
it "can be composed" $ do
let input = " push 4 \n\
\ push 5 \n\
\ push 6 \n\
\ push 7 \n\
\ push 8 \n\
\ roll \n\
\ roll \n\
\ roll \n\
\ halt "
let expected = done [5, 4, 8, 7, 6] 13 (-1)
actual <- run input
actual `shouldBe` expected
it "does not change the stack order when rolling number equals the stack size" $ do
let input = " push 4 \n\
\ push 5 \n\
\ push 6 \n\
\ push 7 \n\
\ push 8 \n\
\ roll \n\
\ roll \n\
\ roll \n\
\ roll \n\
\ roll \n\
\ halt "
let expected = done [8, 7, 6, 5, 4] 15 (-1)
actual <- run input
actual `shouldBe` expected
it "works in the context of current frame" $ do
let input = " push 1 \n\
\ push 2 \n\
\ push 3 \n\
\ call &foo \n\
\ foo: push 10 \n\
\ push 20 \n\
\ push 30 \n\
\ call &bar \n\
\ bar: push 70 \n\
\ push 80 \n\
\ push 90 \n\
\ roll \n\
\ halt "
let expected = done [80, 70, 90, 16, 3, 30, 20, 10, 8, -1, 3, 2, 1] 23 8
-- ├────────┤ ├────────┤ ├─────┤
-- │ │ │ │ └─────┴── there are no 'roll' instructions under the root so the data is in the correct order
-- │ │ └────────┴────────────────── as above - no 'roll' instruction under the 'foo' function
-- └────────┴───────────────────────────────────── the 'roll' instruction is called under the 'bar' function, so the numbers are rolled
actual <- run input
actual `shouldBe` expected
describe "over" $ do describe "over" $ do
it "pushes the second value from the top" $ do it "pushes the second value from the top" $ do
@@ -1017,7 +915,7 @@ spec = do
\ push 3 \n\ \ push 3 \n\
\ ldl 0 \n\ \ ldl 0 \n\
\ halt " \ halt "
let expected = Left "No active stack frame to load local variable" let expected = Left "No active stack frame"
actual <- run input actual <- run input
actual `shouldBe` expected actual `shouldBe` expected
@@ -1040,7 +938,7 @@ spec = do
\ push 3 \n\ \ push 3 \n\
\ stl 0 \n\ \ stl 0 \n\
\ halt " \ halt "
let expected = Left "No active stack frame to store local variable" let expected = Left "No active stack frame"
actual <- run input actual <- run input
actual `shouldBe` expected actual `shouldBe` expected