diff --git a/README.md b/README.md index 06eb093..6028f6d 100644 --- a/README.md +++ b/README.md @@ -28,10 +28,9 @@ List of available instructions: | ``0x16`` | ``IN`` | Read input from stdin | | ``0x17`` | ``OUT`` | Put top stack value to stdout as char | | ``0x18`` | ``CLR x`` | Wipe out ``x`` values before the top value from the stack | -| ``0x19`` | ``ROLL`` | Rotate the stack/stack frame | -| ``0x1A`` | ``OVER`` | Duplicate and push the second value from the top | -| ``0x1B`` | ``LDL x`` | Lift the ``x`` from the _fp_ variable to the top of the stack | -| ``0x1C`` | ``STL x`` | Store the top stack value under the ``x`` from the _fp_ variable | +| ``0x19`` | ``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`` | ``STL x`` | Store the top stack value under the ``x`` from the _fp_ variable | ## Example ### Example 1 diff --git a/app/Assembler/Compiler.hs b/app/Assembler/Compiler.hs index e4b6abf..d761bcd 100644 --- a/app/Assembler/Compiler.hs +++ b/app/Assembler/Compiler.hs @@ -7,4 +7,4 @@ import Assembler.Parser (parse) import Assembler.Emitter (emit) compile :: String -> Either String [Word8] -compile input = return input >>= tokenize >>= parse >>= emit +compile input = tokenize input >>= parse >>= emit diff --git a/app/Assembler/Emitter.hs b/app/Assembler/Emitter.hs index 55c6b80..eb2f7c4 100644 --- a/app/Assembler/Emitter.hs +++ b/app/Assembler/Emitter.hs @@ -12,18 +12,18 @@ import qualified Data.Map as M import Assembler.Parser (AST(..), Scope(..)) -data Bean = Byte Word8 +data Bean = Byte Word8 | Reference String deriving (Show, Eq) data Context = Context { _beans :: [Bean] - , _labels :: M.Map String Int + , _labels :: M.Map String Int , _currentLabel :: Maybe String } deriving (Show, Eq) type Emitter = AST -> ExceptT String (State 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 = lift $ do @@ -32,17 +32,17 @@ emitBean bean = lift $ do return () emitByte :: Word8 -> ExceptT String (State Context) () -emitByte byte = emitBean $ Byte $ byte +emitByte byte = emitBean $ Byte byte emitParam :: Emitter -emitParam (Param (Integer x)) = emitByte $ fromIntegral $ x -emitParam (Param (LabelRef Global l)) = emitBean $ Reference $ l +emitParam (Param (Integer x)) = emitByte $ fromIntegral x +emitParam (Param (LabelRef Global l)) = emitBean $ Reference l emitParam (Param (LabelRef Local l)) = do ctx <- lift get scope <- case _currentLabel ctx of (Just s) -> return s 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" emitLabelDef :: Emitter @@ -50,7 +50,7 @@ emitLabelDef (LabelDef Global label) = do ctx <- lift get let labels = _labels 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 } return () 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" let canonicalLabel = scope ++ "." ++ label let current = length (_beans ctx) - when (canonicalLabel `M.member` labels) (throwError $ "Label '" ++ (label) ++ "' is already defined in the global label '" ++ scope ++ "' scope") + when (canonicalLabel `M.member` labels) (throwError $ "Label '" ++ label ++ "' is already defined in the global label '" ++ scope ++ "' scope") put ctx { _labels = M.insert canonicalLabel current labels } - return () + return () emitLabelDef _ = throwError "Label definition expected" emitInstr :: Emitter @@ -71,7 +71,6 @@ emitInstr (Instruction (Operator op) Empty) = emitByte $ fromIntegral . fromEnum emitInstr (Instruction (Operator op) (Params params)) = do emitByte $ fromIntegral $ fromEnum op mapM_ emitParam params - return () emitInstr _ = throwError "Instruction expected" emitLine :: Emitter @@ -81,26 +80,26 @@ emitLine (Line labelDef instr) = emitLabelDef labelDef >> emitInstr instr >> ret emitLine _ = throwError "Line of code expected" emitProgram :: Emitter -emitProgram (Program progLines) = mapM emitLine progLines >> return () +emitProgram (Program progLines) = mapM_ emitLine progLines emitProgram _ = throwError "Program code expected" resolveLabels :: M.Map String Int -> [Bean] -> Either String [Bean] resolveLabels labels beans = sequence $ foldr folder [] beans where - folder b acc = (resolveLabel labels b) : acc + folder b acc = resolveLabel labels b : acc resolveLabel :: M.Map String Int -> Bean -> Either String Bean resolveLabel _ b@(Byte _) = Right b resolveLabel labels (Reference label) = case M.lookup label labels of (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 root = do - ctx <- flip evalState empty $ runExceptT $ emitProgram root >> lift get +emit root = do + ctx <- flip evalState empty $ runExceptT $ emitProgram root >> lift get let labels = _labels ctx let beans = _beans ctx resolved <- resolveLabels labels beans - return $ map (\(Byte b) -> b) resolved - + return $ map (\(Byte b) -> b) resolved + \ No newline at end of file diff --git a/app/Assembler/Parser.hs b/app/Assembler/Parser.hs index 3201ff2..104322b 100644 --- a/app/Assembler/Parser.hs +++ b/app/Assembler/Parser.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} module Assembler.Parser where import Data.List (intercalate) @@ -10,7 +11,7 @@ import Util (explode) data Scope = Local | Global deriving (Eq, Show, Enum, Bounded) data AST = Empty - | Operator Op + | Operator Op | Integer Int | Identifier String | Colon @@ -21,8 +22,8 @@ data AST = Empty | Param AST | Params [AST] | Instruction AST AST - | Line AST AST - | Program [AST] + | Line AST AST + | Program [AST] deriving (Eq, Show) type ConsumedTokens = Int @@ -43,36 +44,36 @@ parseInt _ = Nothing -- ID := [alnum, '_']+ parseIdentifier :: Parser parseIdentifier ((T.Identifier iden):_) = Just $ ParseResult (Identifier iden) 1 -parseIdentifier _ = Nothing +parseIdentifier _ = Nothing -- ':' parseColon :: Parser -parseColon ((T.Colon):_) = Just $ ParseResult Colon 1 -parseColon _ = Nothing +parseColon (T.Colon:_) = Just $ ParseResult Colon 1 +parseColon _ = Nothing -- '&' parseAmpersand :: Parser -parseAmpersand ((T.Ampersand):_) = Just $ ParseResult Ampersand 1 -parseAmpersand _ = Nothing +parseAmpersand (T.Ampersand:_) = Just $ ParseResult Ampersand 1 +parseAmpersand _ = Nothing -- '.' parseDot :: Parser -parseDot ((T.Dot):_) = Just $ ParseResult Dot 1 -parseDot _ = Nothing +parseDot (T.Dot:_) = Just $ ParseResult Dot 1 +parseDot _ = Nothing -- label_def := '.'? ID ':' parseLabelDef :: Parser -parseLabelDef = parseSeq [parseOptionally parseDot, parseIdentifier, parseColon] combine +parseLabelDef = parseSeq [parseOptionally parseDot, parseIdentifier, parseColon] combine where - combine [Dot, (Identifier iden), _] = LabelDef Local iden - combine [_, (Identifier iden), _] = LabelDef Global iden + combine [Dot, Identifier iden, _] = LabelDef Local iden + combine [_, Identifier iden, _] = LabelDef Global iden -- label_ref := '&' ID parseLabelRef :: Parser parseLabelRef = parseSeq [parseAmpersand, parseOptionally parseDot, parseIdentifier] combine where - combine [_, Dot, (Identifier iden)] = LabelRef Local iden - combine [_, _, (Identifier iden)] = LabelRef Global iden + combine [_, Dot, Identifier iden] = LabelRef Local iden + combine [_, _, Identifier iden] = LabelRef Global iden -- param := INT | label_ref parseParam :: Parser @@ -107,17 +108,17 @@ parseMany :: Parser -> ([AST] -> AST) -> Parser parseMany parser combiner tokens = if null asts then Nothing else Just $ ParseResult ast consumed - where + where results = parseGreedy parser tokens consumed = sum $ map (\(ParseResult _ c) -> c) results - asts = map (\(ParseResult a _) -> a) results + asts = map (\(ParseResult a _) -> a) results ast = combiner asts -- a a a a a a a... parseGreedy :: Parser -> [T.Token] -> [ParseResult] parseGreedy parser tokens = case parser tokens of (Just r@(ParseResult _ consumed)) -> r : parseGreedy parser (drop consumed tokens) - Nothing -> [] + Nothing -> [] -- a | b | c parseAlt :: [Parser] -> (AST -> AST) -> Parser @@ -137,7 +138,7 @@ parseSeq parsers combiner tokens = do results <- parseAll parsers tokens let consumed = sum $ map (\(ParseResult _ c) -> c) results let asts = map (\(ParseResult a _) -> a) results - if (length asts) == (length parsers) + if length asts == length parsers then return $ ParseResult (combiner asts) consumed else Nothing @@ -147,7 +148,7 @@ parseAll [] _ = Just [] parseAll (p:ps) tokens = do (ParseResult ast consumed) <- p tokens rest <- parseAll ps (drop consumed tokens) - return $ (ParseResult ast consumed) : rest + return $ ParseResult ast consumed : rest -- 'Nothing' if not consumed tokens exist assertConsumed :: Parser -> Parser @@ -162,8 +163,8 @@ parse :: [T.Token] -> Either String AST parse tokens = do let codeLines = explode (==T.NewLine) tokens let results = map (assertConsumed parseLine) codeLines - let errors = filter ((==Nothing) . snd) $ zipWith (,) codeLines $ results - let errorMsg = "Parse error(s):\n" ++ (intercalate "\n" $ map (show . fst) errors) + let errors = filter ((==Nothing) . snd) $ zip codeLines results + let errorMsg = "Parse error(s):\n" ++ intercalate "\n" (map (show . fst) errors) case sequenceA results of (Just r) -> return $ Program $ map (\(ParseResult ast _) -> ast) r Nothing -> Left errorMsg \ No newline at end of file diff --git a/app/Assembler/Tokenizer.hs b/app/Assembler/Tokenizer.hs index c106bfa..e1e7417 100644 --- a/app/Assembler/Tokenizer.hs +++ b/app/Assembler/Tokenizer.hs @@ -8,8 +8,8 @@ import VirtualMachine.VM (Op(..)) import Util (toLowerCase, controlChar, unescape) -data Token = Operator Op - | IntLiteral Int +data Token = Operator Op + | IntLiteral Int | StringLiteral String | Identifier String | Colon @@ -38,59 +38,52 @@ keywordTokenizer cs kwd token input matches = and zipped && len == length zipped 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 = anyTokenizer $ map operatorTokenizer ops - where - ops = sortBy cmp [Nop ..] - cmp x y = (length . show) y `compare` (length . show) x +tokenizeOperators = anyTokenizer $ map operatorTokenizer $ sortBy cmp [Nop ..] + where cmp x y = (length . show) y `compare` (length . show) x tokenizeIdentifier :: Tokenizer tokenizeIdentifier [] = Nothing tokenizeIdentifier input@(x:_) = if null identifier || (not . isAlpha) x then Nothing else Just $ TokenizeResult (Identifier identifier) (length identifier) - where - identifier = takeWhile (or . sequenceA [isAlphaNum, (=='_')]) input + where identifier = takeWhile (or . sequenceA [isAlphaNum, (=='_')]) input tokenizeWhitespace :: Tokenizer tokenizeWhitespace [] = Nothing tokenizeWhitespace (x:_) | isSpace x = Just $ TokenizeResult WhiteSpace 1 - | otherwise = Nothing + | otherwise = Nothing tokenizeDecimal :: Tokenizer tokenizeDecimal [] = Nothing tokenizeDecimal input = if null numberStr then Nothing else Just $ TokenizeResult (IntLiteral number) len - where + where number = read numberStr len = length numberStr numberStr = takeWhile isDigit input tokenizeHex :: Tokenizer -tokenizeHex [] = Nothing -tokenizeHex input = if isPrefix && len > 0 - then Just $ TokenizeResult (IntLiteral number) (len + 2) - else Nothing - where - isPrefix = take 2 input == "0x" - number = read . ("0x"++) $ numberStr - len = length numberStr - numberStr = takeWhile isHexDigit (drop 2 input) +tokenizeHex ('0':'x':input) = if null input + then Nothing + else Just $ TokenizeResult (IntLiteral $ read $ "0x" ++ numberStr) (length numberStr + 2) + where numberStr = takeWhile isHexDigit input +tokenizeHex _ = Nothing tokenizeChar :: Tokenizer 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 tokenizeString :: Tokenizer tokenizeString ('"':xs) = do string <- extractString xs unescaped <- unescape string - return $ TokenizeResult (StringLiteral unescaped) (length string + 2) + return $ TokenizeResult (StringLiteral unescaped) (length string + 2) where extractString [] = Nothing extractString (y:ys) @@ -100,13 +93,9 @@ tokenizeString ('"':xs) = do tokenizeString _ = Nothing tokenizeComment :: Tokenizer -tokenizeComment [] = Nothing -tokenizeComment (x:xs) = if x == ';' - then Just $ TokenizeResult (Comment comment) (len + 1) - else Nothing - where - len = length comment - comment = takeWhile (/='\n') xs +tokenizeComment (';':xs) = Just $ TokenizeResult (Comment comment) (length comment + 1) + where comment = takeWhile (/='\n') xs +tokenizeComment _ = Nothing type SeparatorPredicate = Char -> Bool sepTokenizer :: SeparatorPredicate -> Tokenizer -> Tokenizer @@ -115,7 +104,7 @@ sepTokenizer predicate tokenizer input = do result@(TokenizeResult _ consumed) <- tokenizer input let next = drop consumed input if null next || (predicate . head $ next) - then return $ result + then return result else Nothing anyTokenizer :: [Tokenizer] -> Tokenizer @@ -124,7 +113,7 @@ anyTokenizer tokenizers input = getFirst . mconcat . map First $ sequenceA token tokenize :: String -> Either String [Token] tokenize [] = Right [] -tokenize input = tokens >>= (\t -> Right $ filter tokenFilter t) +tokenize input = tokens >>= (Right . filter tokenFilter) where tokens = case tokenizers input of (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 (WhiteSpace) = False +tokenFilter WhiteSpace = False tokenFilter (Comment _) = False tokenFilter _ = True \ No newline at end of file diff --git a/app/Main.hs b/app/Main.hs index f2cd37d..5056729 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,8 +1,8 @@ module Main where -import System.Environment +import System.Environment (getArgs) -import Runner (run, runDebug) +import Runner (run) main :: IO () main = do @@ -11,5 +11,5 @@ main = do result <- run input case result of (Right vm) -> do - putStrLn $ "\n\nDone:\n" ++ (show vm) + putStrLn $ "\nDone\n" ++ show vm (Left err) -> putStrLn $ "\n\nError:\n" ++ err diff --git a/app/Runner.hs b/app/Runner.hs index ca5605b..a28cc2a 100644 --- a/app/Runner.hs +++ b/app/Runner.hs @@ -16,4 +16,4 @@ runDebug :: String -> IO (Either String VM) runDebug = exec empty { _debug = True } exec :: VM -> String -> IO (Either String VM) -exec vm input = runExceptT $ return input >>= (except . compile) >>= (liftIO . VM.run vm . B.pack) >>= except >>= return \ No newline at end of file +exec vm input = runExceptT $ (except . compile) input >>= (liftIO . VM.run vm . B.pack) >>= except \ No newline at end of file diff --git a/app/Util.hs b/app/Util.hs index 6e8447f..969f605 100644 --- a/app/Util.hs +++ b/app/Util.hs @@ -9,7 +9,6 @@ module Util ( ) where import Prelude hiding (head) -import Data.List hiding (head) import Data.Word (Word8) import Data.Char (chr, toLower) import Numeric (showHex) @@ -19,10 +18,10 @@ toLowerCase :: String -> String toLowerCase = map toLower 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 = pad '0' 2 . (flip showHex) "" . (fromIntegral :: Word8 -> Integer) +byteStr = pad '0' 2 . flip showHex "" . (fromIntegral :: Word8 -> Integer) insertAtN :: a -> Int -> [a] -> [a] insertAtN c n xs = insertAtN' n xs @@ -40,7 +39,7 @@ head (x:_) = Just x unescape :: String -> Maybe String unescape ('\\':x:xs) = do - cc <- fmap chr $ controlChar x + cc <- chr <$> controlChar x rest <- unescape xs return $ cc : rest unescape (x:xs) = unescape xs >>= (\rest -> return $ x : rest) @@ -62,9 +61,9 @@ controlChar x = case x of _ -> Nothing explode :: (Foldable f) => (a -> Bool) -> f a -> [[a]] -explode predicate xs = filter (not . null) $ foldr split [[]] xs - where +explode predicate xs = filter (not . null) $ foldr split [[]] xs + where split _ [] = [] - split y (ys:yss) + split y (ys:yss) | predicate y = []:ys:yss - | otherwise = (y:ys):yss \ No newline at end of file + | otherwise = (y:ys):yss \ No newline at end of file diff --git a/app/VirtualMachine/Instruction.hs b/app/VirtualMachine/Instruction.hs index 5c56b8d..813965e 100644 --- a/app/VirtualMachine/Instruction.hs +++ b/app/VirtualMachine/Instruction.hs @@ -1,46 +1,45 @@ +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} module VirtualMachine.Instruction where import Data.Char (chr, ord) import Data.Word (Word8) -import System.IO (stdin, hGetChar) -import Control.Monad (unless) +import Control.Monad (void) import Control.Monad.Except (throwError) -import Control.Monad.Trans (lift, liftIO) -import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans (liftIO) import qualified Data.Map as M 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 Pops = [Int] type Pushes = S.Seq Int -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 () } +data Instruction = Simple { _op :: Op, _noParams :: Int, _noPops :: Int, _sAction :: Params -> Pops -> Pushes } + | Complex { _op :: Op, _noParams :: Int, _noPops :: Int, _cAction :: Params -> Pops -> Computation () } instance Show Instruction where - 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 (Simple op noParams noPops _) = show op ++ "(S," ++ show noParams ++ "," ++ show noPops ++ ")" + show (Complex op noParams noPops _) = show op ++ "(C," ++ show noParams ++ "," ++ show noPops ++ ")" data Unit = Instr { _instr :: Instruction } | Byte { _byte :: Word8 } deriving (Show) instructions :: [Instruction] -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 = Pop, _noParams = 0, _noPops = 1, _sAction = (\_ _ -> S.empty) } - , 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 = 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 = 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 = 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 = Over, _noParams = 0, _noPops = 2, _sAction = (\_ [x, y] -> S.fromList [y, x, y]) } +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 = Pop, _noParams = 0, _noPops = 1, _sAction = \_ _ -> S.empty } + , 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 = 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 = 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 = 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 = Over, _noParams = 0, _noPops = 2, _sAction = \_ [x, y] -> S.fromList [y, x, y] } , Complex { _op = Halt, _noParams = 0, _noPops = 0, _cAction = halt } , Complex { _op = Call, _noParams = 1, _noPops = 0, _cAction = call } , 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 = Jge, _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 = Out, _noParams = 0, _noPops = 1, _cAction = output } , 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 = Stl, _noParams = 1, _noPops = 1, _cAction = storeLocal } ] 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 _ _ = lift $ do - setHalt True - return () +halt :: Params -> Pops -> Computation () +halt _ _ = setHalt True -call :: Params -> Pops -> ExceptT String Machine () -call (addr:_) _ = lift $ do +call :: Params -> Pops -> Computation () +call (addr:_) _ = do fp <- getFp - fp' <- getStackSize - retAddr <- getPc >>= return . (+2) - + fp' <- getStackSize + retAddr <- (+2) <$> getPc + push [retAddr, fp] setPc addr - setFp fp' - - return () -call [] _ = throwError "Address excepted" - -ret :: Params -> Pops -> ExceptT String Machine () + setFp fp' + +ret :: Params -> Pops -> Computation () 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 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 () -loadLocal (index:_) _ = do - 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" + fp' <- frameAt 0 id "frame pointer (fp)" + retAddr <- frameAt 1 id "return address" -storeLocal :: Params -> Pops -> ExceptT String Machine () -storeLocal (index:_) (val:_) = do - fp <- lift getFp - unless (fp > -1) (throwError "No active stack frame to store local variable") - stackSize <- lift getStackSize - lift $ setAt (stackSize - fp - 3 - index) val - lift $ forward 2 - return () -storeLocal [] _ = throwError "Local variable index expected" -storeLocal _ [] = throwError "Empty stack - nothing to store" \ No newline at end of file + if stackSize - fp == 2 + then void $ pop (stackSize - fp) + else pop 1 >>= \retVal -> pop (stackSize - fp - 1) >> push retVal + + setFp fp' + setPc retAddr + +jump :: Params -> Pops -> Computation () +jump (addr:_) _ = setPc addr + +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" \ No newline at end of file diff --git a/app/VirtualMachine/Interpreter.hs b/app/VirtualMachine/Interpreter.hs index ce3f1eb..92c02b7 100644 --- a/app/VirtualMachine/Interpreter.hs +++ b/app/VirtualMachine/Interpreter.hs @@ -4,15 +4,14 @@ import Data.Word (Word8) import Data.List (intercalate) import Control.Monad (when, unless) -import Control.Monad.Trans.State (get, evalStateT) -import Control.Monad.Trans.Except (ExceptT, except, runExceptT) -import Control.Monad.Trans (lift) +import Control.Monad.Trans.State (evalStateT) +import Control.Monad.Trans.Except (except, runExceptT) import Control.Monad.Except (throwError) import Control.Monad.State (liftIO) import qualified Data.Map as M 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) @@ -24,7 +23,7 @@ parseInstr (opCode:rest) = do Nothing -> Left "Unknown instruction" let noParams = _noParams instr let params = map fromIntegral $ take noParams rest :: [Word8] - unless (length params == noParams) (Left $ "Expected " ++ (show noParams) ++ " parameter(s), got " ++ (show $ length params) ++ " for operator '" ++ (show op) ++ "'") + unless (length params == noParams) (Left $ "Expected " ++ show noParams ++ " parameter(s), got " ++ show (length params) ++ " for operator '" ++ show op ++ "'") return (instr, params) parseInstr [] = Left "Unexpected end of the file" @@ -37,68 +36,61 @@ parse code = do rest <- parse (drop (noParams + 1) code) return $ [Instr instr] ++ paramBytes ++ rest -interpret :: [Unit] -> ExceptT String Machine () -interpret units = do - halted <- lift isHalted - if halted - then return () - else do - interpretUnit units - interpret units - -interpretUnit :: [Unit] -> ExceptT String Machine () +interpret :: [Unit] -> Computation () +interpret units = isHalted >>= \halted -> unless halted $ interpretUnit units >> interpret units + +interpretUnit :: [Unit] -> Computation () interpretUnit [] = throwError "Nothing to interpret" interpretUnit units = do - pc <- lift getPc + pc <- getPc 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 (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 - debug <- lift isDebug - - when debug $ lift $ do + debug <- isDebug + + when debug $ do vm <- get pc <- getPc let noParams = _noParams instr - let params = intercalate "" $ map (show . _byte) $ take noParams $ drop (pc + 1) $ units - liftIO $ putStrLn $ show vm - liftIO $ putStrLn $ (show pc) ++ ": " ++ (show $ _op instr) ++ " " ++ params + let params = intercalate "" $ map (show . _byte) $ take noParams $ drop (pc + 1) units + liftIO $ print vm + liftIO $ putStrLn $ show pc ++ ": " ++ show (_op instr) ++ " " ++ params case instr of Simple {} -> interpretSimple units instr Complex {} -> interpretComplex units instr -interpretSimple :: [Unit] -> Instruction -> ExceptT String Machine () +interpretSimple :: [Unit] -> Instruction -> Computation () interpretSimple units instr = do - pc <- lift getPc - let noParams = _noParams instr - let noPops = _noPops instr - let paramBytes = take noParams $ drop (pc + 1) $ units - let params = map (fromIntegral . _byte) paramBytes + pc <- getPc + let noParams = _noParams instr + let noPops = _noPops instr + let paramBytes = take noParams $ drop (pc + 1) units + let params = map (fromIntegral . _byte) paramBytes let action = _sAction instr - pops <- lift $ pop noPops - unless (length pops == noPops) (throwError $ "Attempt to pop from empty stack: tried to pop " ++ (show noPops) ++ " elements, got " ++ (show $ length pops)) + pops <- pop noPops + 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 - lift $ pushS pushes - lift $ forward $ noParams + 1 - return () + pushS pushes + forward $ noParams + 1 -interpretComplex :: [Unit] -> Instruction -> ExceptT String Machine () +interpretComplex :: [Unit] -> Instruction -> Computation () interpretComplex units instr = do - pc <- lift getPc - let noParams = _noParams instr - let noPops = _noPops instr - let paramBytes = take noParams $ drop (pc + 1) $ units - let params = map (fromIntegral . _byte) paramBytes + pc <- getPc + let noParams = _noParams instr + let noPops = _noPops instr + let paramBytes = take noParams $ drop (pc + 1) units + let params = map (fromIntegral . _byte) paramBytes let action = _cAction instr - pops <- lift $ pop noPops - unless (length pops == noPops) (throwError $ "Attempt to pop from empty stack: tried to pop " ++ (show noPops) ++ " elements, got " ++ (show $ length pops)) + pops <- pop noPops + unless (length pops == noPops) (throwError $ "Attempt to pop from empty stack: tried to pop " ++ show noPops ++ " elements, got " ++ show (length pops)) action params pops run :: VM -> B.ByteString -> IO (Either String VM) run vm input = evalStateT (runExceptT machine) vm - where machine = (return input) >>= (return .B.unpack) >>= (except . parse) >>= interpret >> (lift get) \ No newline at end of file + where machine = (except . parse . B.unpack) input >>= interpret >> get diff --git a/app/VirtualMachine/VM.hs b/app/VirtualMachine/VM.hs index 2699a3b..a8c9e52 100644 --- a/app/VirtualMachine/VM.hs +++ b/app/VirtualMachine/VM.hs @@ -3,11 +3,13 @@ module VirtualMachine.VM where import Text.Printf (printf) import Data.Foldable (toList) import Control.Monad.Trans (lift) -import Control.Monad.State (get, put) import Control.Monad.Except (throwError) import Control.Monad.Trans.State (StateT) import Control.Monad.Trans.Except (ExceptT) 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 @@ -45,14 +47,15 @@ data Op = Nop -- 0x00 | In -- 0x16 | Out -- 0x17 | Clr -- 0x18 - | Roll -- 0x19 - | Over -- 0x1A - | Ldl -- 0x1B - | Stl -- 0x1C + | Over -- 0x19 + | Ldl -- 0x1A + | Stl -- 0x1B deriving (Eq, Ord, Enum, Show, Read, Bounded) type Machine = StateT VM IO +type Computation = ExceptT String Machine + empty :: VM empty = VM { _pc = 0 , _fp = -1 @@ -63,69 +66,71 @@ empty = VM { _pc = 0 ------------------------------------------------------------------------------- -getPc :: Machine Int -getPc = get >>= (return . _pc) +get :: Computation VM +get = lift ST.get -getFp :: Machine Int -getFp = get >>= (return . _fp) +put :: VM -> Computation () +put x = lift $ ST.put x -isHalted :: Machine Bool -isHalted = get >>= (return . _halt) +getPc :: Computation Int +getPc = get <&> _pc -isDebug :: Machine Bool -isDebug = get >>= (return . _debug) +getFp :: Computation Int +getFp = get <&> _fp -getAt :: Int -> String -> ExceptT String Machine Int -getAt index err = do - vm <- lift $ get - let stack = _stack vm - case (stack S.!? index) of +isHalted :: Computation Bool +isHalted = get <&> _halt + +isDebug :: Computation Bool +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 - Nothing -> throwError err + Nothing -> throwError $ "Cannot determine " ++ name ++ " - index " ++ show index ++ " out of frame bounds" -setAt :: Int -> Int -> Machine () -setAt index val = do +updateFrameAt :: Int -> Int -> Computation () +updateFrameAt index value = do vm <- get - let stack = _stack vm - let stack' = S.update index val stack - put vm { _stack = stack' } + fp <- getFp + unless (fp > -1) (throwError "No active stack frame") + stackSize <- getStackSize + put vm { _stack = S.update (stackSize - fp - 1 - index) value $ _stack vm } -getStackSize :: Machine Int -getStackSize = get >>= (return . length . _stack) +getStackSize :: Computation Int +getStackSize = get <&> (length . _stack) -setPc :: Int -> Machine () -setPc pc = do - vm <- get - put vm { _pc = pc } +setPc :: Int -> Computation () +setPc pc = get >>= \vm -> put vm { _pc = pc } -setFp :: Int -> Machine () -setFp fp = do - vm <- get - put vm { _fp = fp } +setFp :: Int -> Computation () +setFp fp = get >>= \vm -> put vm { _fp = fp } -setHalt :: Bool -> Machine () -setHalt halt = do - vm <- get - put vm { _halt = halt } +setHalt :: Bool -> Computation () +setHalt halt = get >>= \vm -> put vm { _halt = halt } -pop :: Int -> Machine [Int] +pop :: Int -> Computation [Int] pop count = do vm <- get let stack = _stack vm - put vm { _stack = S.drop count $ stack } - return $ toList $ S.take count $ stack + put vm { _stack = S.drop count stack } + return $ toList $ S.take count stack -push :: [Int] -> Machine () +push :: [Int] -> Computation () push = pushS . S.fromList -pushS :: S.Seq Int -> Machine () -pushS numbers = do - vm <- get - put vm { _stack = numbers <> _stack vm } - return () +pushS :: S.Seq Int -> Computation () +pushS numbers = get >>= \vm -> put vm { _stack = numbers <> _stack vm } -forward :: Int -> Machine () -forward offset = do - vm <- get - put vm { _pc = _pc vm + offset } - return () \ No newline at end of file +forward :: Int -> Computation () +forward offset = get >>= \vm -> put vm { _pc = _pc vm + offset } \ No newline at end of file diff --git a/test/Assembler/EmitterSpec.hs b/test/Assembler/EmitterSpec.hs index efcce6f..ac10e86 100644 --- a/test/Assembler/EmitterSpec.hs +++ b/test/Assembler/EmitterSpec.hs @@ -13,7 +13,7 @@ import Assembler.Emitter as E import VirtualMachine.VM (Op(..)) 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 = do @@ -37,12 +37,12 @@ spec = do let ctx = E.empty { _labels = M.fromList [("main", 0)], _currentLabel = Just "main" } let input = LabelDef Local "foo" 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 let ctx = E.empty { _labels = M.fromList [("main", 0), ("main.foo", 0), ("program", 0)], _currentLabel = Just "program" } 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" }) - evalContext ctx input emitLabelDef `shouldBe` expected + evalContext ctx input emitLabelDef `shouldBe` expected 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 input = LabelDef Local "foo" @@ -84,7 +84,7 @@ spec = do evalContext ctx input emitInstr `shouldBe` expected it "emits bytes for 2-param instruction" $ do 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"] }) evalContext ctx input emitInstr `shouldBe` expected @@ -106,7 +106,7 @@ spec = do \ push 2 \n\ \ jmp &sum \n\ \ sum: add \n\ - \ jmp &main " + \ jmp &main " let (Right tokens) = tokenize input let (Right ast) = parse tokens let expected = [0x02, 0x01, 0x02, 0x02, 0x0e, 0x06, 0x06, 0x0e, 0x00] @@ -123,7 +123,7 @@ spec = do \ push 2 \n\ \ jmp &.sum \n\ \ .sum: add \n\ - \ jmp &.loop " + \ jmp &.loop " let (Right tokens) = tokenize input let (Right ast) = parse tokens -- The differences: &.sum &.loop @@ -138,7 +138,7 @@ spec = do \ push 2 \n\ \ jmp &sum \n\ \ sum: add \n\ - \ jmp &program " + \ jmp &program " let (Right tokens) = tokenize input - let (Right ast) = parse tokens + let (Right ast) = parse tokens emit ast `shouldBe` Left "Label 'program' is not defined" \ No newline at end of file diff --git a/test/Assembler/ParserSpec.hs b/test/Assembler/ParserSpec.hs index 8ad69a4..f6f6d07 100644 --- a/test/Assembler/ParserSpec.hs +++ b/test/Assembler/ParserSpec.hs @@ -17,8 +17,7 @@ spec = do let input = map ((:[]) . T.Operator) ops let expected = map (flip success 1 . Operator) ops map parseOperator input `shouldBe` expected - it "supports non-truncated input" $ do - parseOperator [T.Operator Call, T.Ampersand, T.Identifier "label"] `shouldBe` success (Operator Call) 1 + it "supports non-truncated input" $ parseOperator [T.Operator Call, T.Ampersand, T.Identifier "label"] `shouldBe` success (Operator Call) 1 it "supports empty input" $ parseOperator [] `shouldBe` Nothing @@ -28,35 +27,31 @@ spec = do let input = map ((:[]) . T.IntLiteral) ints let expected = map (flip success 1 . Integer) ints map parseInt input `shouldBe` expected - it "supports non-truncated input" $ do - parseInt [T.IntLiteral 4, T.Colon] `shouldBe` success (Integer 4) 1 + it "supports non-truncated input" $ parseInt [T.IntLiteral 4, T.Colon] `shouldBe` success (Integer 4) 1 it "supports empty input" $ parseInt [] `shouldBe` Nothing describe "parseIdentifier" $ do it "accepts identifier tokens" $ parseIdentifier [T.Identifier "someId"] `shouldBe` success (Identifier "someId") 1 - it "supports non-truncated input" $ do - parseIdentifier [T.Identifier "label", T.Colon] `shouldBe` success (Identifier "label") 1 + it "supports non-truncated input" $ parseIdentifier [T.Identifier "label", T.Colon] `shouldBe` success (Identifier "label") 1 it "supports empty input" $ parseIdentifier [] `shouldBe` Nothing describe "parseColon" $ do it "accepts colon tokens" $ parseColon [T.Colon] `shouldBe` success Colon 1 - it "supports non-truncated input" $ do - parseColon [T.Colon, T.Operator Add] `shouldBe` success Colon 1 + it "supports non-truncated input" $ parseColon [T.Colon, T.Operator Add] `shouldBe` success Colon 1 it "supports empty input" $ parseColon [] `shouldBe` Nothing describe "parseAmpersand" $ do it "accepts colon tokens" $ parseAmpersand [T.Ampersand] `shouldBe` success Ampersand 1 - it "supports non-truncated input" $ do - parseAmpersand [T.Ampersand, T.Identifier "label"] `shouldBe` success Ampersand 1 + it "supports non-truncated input" $ parseAmpersand [T.Ampersand, T.Identifier "label"] `shouldBe` success Ampersand 1 it "supports empty input" $ - parseAmpersand [] `shouldBe` Nothing - + parseAmpersand [] `shouldBe` Nothing + describe "parseLabelDef" $ do it "parses global label def" $ parseLabelDef [T.Identifier "label", T.Colon] `shouldBe` success (LabelDef Global "label") 2 @@ -65,9 +60,8 @@ spec = do it "requires label" $ parseLabelDef [T.Colon] `shouldBe` Nothing it "requires colon" $ - parseLabelDef [T.Identifier "label"] `shouldBe` Nothing - it "supports non-truncated input" $ do - parseLabelDef [T.Identifier "sum", T.Colon, T.Operator Nop] `shouldBe` success (LabelDef Global "sum") 2 + parseLabelDef [T.Identifier "label"] `shouldBe` Nothing + it "supports non-truncated input" $ parseLabelDef [T.Identifier "sum", T.Colon, T.Operator Nop] `shouldBe` success (LabelDef Global "sum") 2 it "supports empty input" $ parseLabelDef [] `shouldBe` Nothing @@ -79,11 +73,10 @@ spec = do it "requires label" $ parseLabelRef [T.Ampersand] `shouldBe` Nothing it "requires ampersand" $ - parseLabelRef [T.Identifier "label"] `shouldBe` Nothing - it "supports non-truncated input" $ do - parseLabelRef [T.Ampersand, T.Identifier "sum", T.Operator Nop] `shouldBe` success (LabelRef Global "sum") 2 + parseLabelRef [T.Identifier "label"] `shouldBe` Nothing + it "supports non-truncated input" $ parseLabelRef [T.Ampersand, T.Identifier "sum", T.Operator Nop] `shouldBe` success (LabelRef Global "sum") 2 it "supports empty input" $ - parseLabelRef [] `shouldBe` Nothing + parseLabelRef [] `shouldBe` Nothing describe "parseParam" $ do it "parses int params" $ do @@ -96,9 +89,9 @@ spec = do parseParam [T.Ampersand, T.Identifier "program"] `shouldBe` expected it "supports non-truncated input" $ do 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" $ - parseParam [] `shouldBe` Nothing + parseParam [] `shouldBe` Nothing describe "parseInstr" $ do it "parses no-param operator" $ do @@ -113,53 +106,53 @@ spec = do let expected = success (Instruction (Operator Push) (Params [ - (Param (Integer 4)) + Param (Integer 4) ]) ) (length input) - parseInstr input `shouldBe` expected + parseInstr input `shouldBe` expected it "parses operator with single label ref param" $ do let input = [T.Operator Call, T.Ampersand, T.Identifier "program"] let expected = success (Instruction (Operator Call) (Params [ - (Param (LabelRef Global "program")) + Param (LabelRef Global "program") ]) ) (length input) - parseInstr input `shouldBe` expected + parseInstr input `shouldBe` expected it "parses operator with multiple int params" $ do let input = [T.Operator Push , T.IntLiteral 1 , T.IntLiteral 4 , T.IntLiteral 2 , T.IntLiteral 0 - ] + ] let expected = success (Instruction (Operator Push) (Params [ - (Param (Integer 1)), - (Param (Integer 4)), - (Param (Integer 2)), - (Param (Integer 0)) + Param (Integer 1), + Param (Integer 4), + Param (Integer 2), + Param (Integer 0) ]) ) (length input) - parseInstr input `shouldBe` expected + parseInstr input `shouldBe` expected it "parses operator with multiple param ref params" $ do let input = [T.Operator Push , T.Ampersand, T.Dot, T.Identifier "program" , T.Ampersand, T.Dot, T.Identifier "main" , T.Ampersand, T.Identifier "foo" , T.Ampersand, T.Dot, T.Identifier "bar" - ] + ] let expected = success (Instruction (Operator Push) (Params [ - (Param (LabelRef Local "program")), - (Param (LabelRef Local "main")), - (Param (LabelRef Global "foo")), - (Param (LabelRef Local "bar")) + Param (LabelRef Local "program"), + Param (LabelRef Local "main"), + Param (LabelRef Global "foo"), + Param (LabelRef Local "bar") ]) ) (length input) - parseInstr input `shouldBe` expected + parseInstr input `shouldBe` expected it "parses operator with multiple mixed params" $ do let input = [T.Operator Push , T.Ampersand, T.Identifier "program" @@ -170,21 +163,21 @@ spec = do , T.IntLiteral 11 , T.Ampersand, T.Dot, T.Identifier "bar" , T.IntLiteral 20 - ] + ] let expected = success (Instruction (Operator Push) (Params [ - (Param (LabelRef Global "program")), - (Param (Integer 4)), - (Param (LabelRef Local "main")), - (Param (LabelRef Global "foo")), - (Param (Integer 10)), - (Param (Integer 11)), - (Param (LabelRef Local "bar")), - (Param (Integer 20)) + Param (LabelRef Global "program"), + Param (Integer 4), + Param (LabelRef Local "main"), + Param (LabelRef Global "foo"), + Param (Integer 10), + Param (Integer 11), + Param (LabelRef Local "bar"), + Param (Integer 20) ]) ) (length input) - parseInstr input `shouldBe` expected + parseInstr input `shouldBe` expected it "supports non-truncated input" $ do let input = [T.Operator Push , T.Ampersand, T.Identifier "program" @@ -196,26 +189,26 @@ spec = do , 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.Operator Call - , T.Ampersand, T.Identifier "program" - ] + , T.Ampersand, T.Identifier "program" + ] let expected = success (Instruction (Operator Push) (Params [ - (Param (LabelRef Global "program")), - (Param (Integer 4)), - (Param (LabelRef Global "main")), - (Param (LabelRef Local "foo")), - (Param (Integer 10)), - (Param (Integer 11)), - (Param (LabelRef Global "bar")), - (Param (Integer 20)) + Param (LabelRef Global "program"), + Param (Integer 4), + Param (LabelRef Global "main"), + Param (LabelRef Local "foo"), + Param (Integer 10), + Param (Integer 11), + Param (LabelRef Global "bar"), + Param (Integer 20) ]) ) 14 - parseInstr input `shouldBe` expected + parseInstr input `shouldBe` expected 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 let input = [T.Dot, T.Identifier "main", T.Colon, T.Operator Call, T.Ampersand, T.Identifier "program"] let expected = success (Line @@ -223,7 +216,7 @@ spec = do (Instruction (Operator Call) (Params [ - (Param (LabelRef Global "program")) + Param (LabelRef Global "program") ]) ) ) (length input) @@ -231,10 +224,10 @@ spec = do it "supports line with just label definition" $ do let input = [T.Identifier "main", T.Colon] let expected = success (Line - (LabelDef Global "main") - Empty + (LabelDef Global "main") + Empty ) (length input) - parseLine input `shouldBe` expected + parseLine input `shouldBe` expected it "supports line with just operator" $ do let input = [T.Operator Call, T.Ampersand, T.Dot, T.Identifier "program"] let expected = success (Line @@ -242,7 +235,7 @@ spec = do (Instruction (Operator Call) (Params [ - (Param (LabelRef Local "program")) + Param (LabelRef Local "program") ]) ) ) (length input) @@ -254,117 +247,117 @@ spec = do (Instruction (Operator Call) (Params [ - (Param (LabelRef Global "program")) + Param (LabelRef Global "program") ]) ) ) 5 - parseLine input `shouldBe` expected + parseLine input `shouldBe` expected it "parses empty input" $ parseLine [] `shouldBe` Nothing - + describe "mapAST" $ 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 input = [T.StringLiteral "Some not important input"] mapAST parser astMapper input `shouldBe` success (Param Colon) 1 it "results Nothing when wrapped parser failed" $ do - let astMapper ast = Param ast + let astMapper = Param let parser = const Nothing let input = [T.StringLiteral "Some not important input"] mapAST parser astMapper input `shouldBe` Nothing it "supports empty input irrespective of wrapped parser" $ do - let astMapper ast = Param ast + let astMapper = Param let parser = const $ success Colon 1 let input = [] mapAST parser astMapper input `shouldBe` Nothing - + describe "parseOptionally" $ do it "returns parsed AST if wrapped parser succeeded" $ do let parser = const $ success Ampersand 1 let input = [T.StringLiteral "Some not important input"] parseOptionally parser input `shouldBe` success Ampersand 1 it "returns Empty if wrapped parser failed" $ do - let parser = const $ Nothing + let parser = const Nothing 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 - let parser = const $ Nothing + let parser = const Nothing let input = [] - parseOptionally parser input `shouldBe` success Empty 0 + parseOptionally parser input `shouldBe` success Empty 0 describe "parseMany" $ do it "parses many occurrences on truncated input" $ do let colonParser (T.Colon:_) = success Colon 1 - colonParser _ = Nothing + colonParser _ = Nothing let combiner = Params let input = [T.Colon, T.Colon, T.Colon] parseMany colonParser combiner input `shouldBe` success (Params [Colon, Colon, Colon]) 3 it "parses single occurence on truncated input" $ do let colonParser (T.Colon:_) = success Colon 1 - colonParser _ = Nothing + colonParser _ = Nothing let combiner = Params 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 let colonParser (T.Colon:_) = success Colon 1 - colonParser _ = Nothing + colonParser _ = Nothing let combiner = Params let input = [T.Colon, T.Colon, T.Colon, T.Ampersand] parseMany colonParser combiner input `shouldBe` success (Params [Colon, Colon, Colon]) 3 it "parses single occurence on non-truncated input" $ do let colonParser (T.Colon:_) = success Colon 1 - colonParser _ = Nothing + colonParser _ = Nothing let combiner = Params 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 let colonParser (T.Colon:_) = success Colon 1 - colonParser _ = Nothing + colonParser _ = Nothing let combiner = Params 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 let colonParser (T.Colon:_) = success Colon 1 - colonParser _ = Nothing + colonParser _ = Nothing let combiner = Params let input = [] - parseMany colonParser combiner input `shouldBe` Nothing + parseMany colonParser combiner input `shouldBe` Nothing describe "parseMany0" $ do it "parses many occurrences on truncated input" $ do let colonParser (T.Colon:_) = success Colon 1 - colonParser _ = Nothing + colonParser _ = Nothing let combiner = Params let input = [T.Colon, T.Colon, T.Colon] parseMany0 colonParser combiner input `shouldBe` success (Params [Colon, Colon, Colon]) 3 it "parses single occurence on truncated input" $ do let colonParser (T.Colon:_) = success Colon 1 - colonParser _ = Nothing + colonParser _ = Nothing let combiner = Params 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 let colonParser (T.Colon:_) = success Colon 1 - colonParser _ = Nothing + colonParser _ = Nothing let combiner = Params let input = [T.Colon, T.Colon, T.Colon, T.Ampersand] parseMany0 colonParser combiner input `shouldBe` success (Params [Colon, Colon, Colon]) 3 it "parses single occurence on non-truncated input" $ do let colonParser (T.Colon:_) = success Colon 1 - colonParser _ = Nothing + colonParser _ = Nothing let combiner = Params 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 let colonParser (T.Colon:_) = success Colon 1 - colonParser _ = Nothing + colonParser _ = Nothing let combiner = Params 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 let colonParser (T.Colon:_) = success Colon 1 - colonParser _ = Nothing + colonParser _ = Nothing let combiner = Params let input = [] parseMany0 colonParser combiner input `shouldBe` success Empty 0 @@ -375,7 +368,7 @@ spec = do , Nothing , Nothing , Nothing - , Nothing + , Nothing ] let input = [T.StringLiteral "some not important input"] parseAny parsers input `shouldBe` success Ampersand 1 @@ -384,7 +377,7 @@ spec = do , Nothing , success (Integer 4) 1 , Nothing - , Nothing + , Nothing , success (LabelDef Local "not me") 2 , Nothing , success (Instruction (Operator Push) Empty) 1 @@ -395,14 +388,14 @@ spec = do , success Colon 1 , 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 it "returns Nothing if no one of the parsers matches the input" $ do - let parsers = map const (take 4 $ repeat $ Nothing) - let input = [T.StringLiteral "some not important input"] + let parsers = replicate 4 (const Nothing) + let input = [T.StringLiteral "some not important input"] parseAny parsers input `shouldBe` Nothing 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 it "supports empty input irrespective of wrapped parsers" $ do let parsers = map const [ success (Integer 4) 1 @@ -413,45 +406,45 @@ spec = do , success Colon 1 ] let input = [] - parseAny parsers input `shouldBe` Nothing - + parseAny parsers input `shouldBe` Nothing + describe "parseSeq" $ do it "parses truncated input" $ do let colonParser (T.Colon:_) = success Colon 1 - colonParser _ = Nothing + colonParser _ = Nothing let ampersandParser (T.Ampersand:_) = success Ampersand 1 - ampersandParser _ = Nothing + ampersandParser _ = Nothing let combiner = Params let pattern = [colonParser, ampersandParser] let input = [T.Colon, T.Ampersand] parseSeq pattern combiner input `shouldBe` success (Params [Colon, Ampersand]) 2 it "parses non-truncated input" $ do let colonParser (T.Colon:_) = success Colon 1 - colonParser _ = Nothing + colonParser _ = Nothing let ampersandParser (T.Ampersand:_) = success Ampersand 1 - ampersandParser _ = Nothing + ampersandParser _ = Nothing let combiner = Params let pattern = [colonParser, ampersandParser] let input = [T.Colon, T.Ampersand, T.Colon] parseSeq pattern combiner input `shouldBe` success (Params [Colon, Ampersand]) 2 it "rejects incomplete pattern" $ do let colonParser (T.Colon:_) = success Colon 1 - colonParser _ = Nothing + colonParser _ = Nothing let ampersandParser (T.Ampersand:_) = success Ampersand 1 - ampersandParser _ = Nothing + ampersandParser _ = Nothing let combiner = Params let pattern = [colonParser, ampersandParser] let input = [T.Colon] - parseSeq pattern combiner input `shouldBe` Nothing + parseSeq pattern combiner input `shouldBe` Nothing it "rejects non-matching input" $ do let colonParser (T.Colon:_) = success Colon 1 - colonParser _ = Nothing + colonParser _ = Nothing let ampersandParser (T.Ampersand:_) = success Ampersand 1 - ampersandParser _ = Nothing + ampersandParser _ = Nothing let combiner = Params let pattern = [colonParser, ampersandParser] 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 let pattern = map const [ success (Integer 4) 1 , 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 let parser = const $ success Colon 1 let input = [T.Colon, T.Ampersand] - assertConsumed parser input `shouldBe` Nothing + assertConsumed parser input `shouldBe` Nothing it "supports empty input" $ do let parser = const $ success Colon 1 let input = [] - assertConsumed parser input `shouldBe` Nothing + assertConsumed parser input `shouldBe` Nothing describe "parse" $ do it "parses empty input" $ do @@ -486,11 +479,11 @@ spec = do let input = "add1_2: push 1\npush 2\nadd" let (Right tokens) = T.tokenize input -- Labels: Operations: Params: - 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 Add) Empty)) + 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 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 let input = "push 1 add" let (Right tokens) = T.tokenize input @@ -500,9 +493,9 @@ spec = do let (Right tokens) = T.tokenize input 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 - let input = "pop label:" + let input = "pop label:" 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 let inputs = ["id", "push id", "main: id", "id main:"] 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[Identifier \"label\",IntLiteral 5,Colon]" ] :: [Either String AST] - map parse tokens `shouldBe` expected + map parse tokens `shouldBe` expected it "parses example #1" $ do let input = "main: ; here we define some main label\n\ \ push 7 ; we push 7 to the stack\n\ @@ -533,12 +526,12 @@ spec = do \ ret" let (Right tokens) = T.tokenize input -- Labels: Operations: Params: - 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 4]))) - , (Line Empty (Instruction (Operator Call) (Params [Param $ LabelRef Global "sum"]))) - , (Line Empty (Instruction (Operator Halt) Empty)) - , (Line (LabelDef Global "sum") (Instruction (Operator Add) Empty)) - , (Line Empty (Instruction (Operator Ret) 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 4])) + , Line Empty (Instruction (Operator Call) (Params [Param $ LabelRef Global "sum"])) + , Line Empty (Instruction (Operator Halt) Empty) + , Line (LabelDef Global "sum") (Instruction (Operator Add) Empty) + , Line Empty (Instruction (Operator Ret) Empty) ] - parse tokens `shouldBe` (Right $ expected :: Either String AST) \ No newline at end of file + parse tokens `shouldBe` (Right expected :: Either String AST) \ No newline at end of file diff --git a/test/Assembler/TokenizerSpec.hs b/test/Assembler/TokenizerSpec.hs index 1b2aa9a..0655189 100644 --- a/test/Assembler/TokenizerSpec.hs +++ b/test/Assembler/TokenizerSpec.hs @@ -12,7 +12,7 @@ success token consumed = Just $ TokenizeResult token consumed spec :: Spec spec = do - describe "keywordTokenizer" $ do + describe "keywordTokenizer" $ do it "supports truncated input" $ keywordTokenizer True "hey" NewLine "hey" `shouldBe` success NewLine 3 it "supports non-truncated input" $ @@ -20,12 +20,12 @@ spec = do it "supports case sensitivity" $ keywordTokenizer True "hey" NewLine "heYjude" `shouldBe` Nothing 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" $ keywordTokenizer True "hey" Colon "heyjude" `shouldBe` success Colon 3 it "returns Nothing if input does not match" $ keywordTokenizer True "hey" Colon "xheyjude" `shouldBe` Nothing - it "supports empty input" $ + it "supports empty input" $ keywordTokenizer True "hey" Colon "" `shouldBe` Nothing describe "operatorTokenizer" $ do @@ -35,7 +35,7 @@ spec = do operatorTokenizer Pop "pops" `shouldBe` success (Operator Pop) 3 it "returns Nothing if input does not match" $ operatorTokenizer Pop "poop" `shouldBe` Nothing - it "supports empty input" $ + it "supports empty input" $ operatorTokenizer Call "" `shouldBe` Nothing describe "tokenizeOperators" $ do @@ -53,7 +53,7 @@ spec = do map tokenizeOperators input `shouldBe` expected it "rejects other input" $ tokenizeOperators "some unsupported input" `shouldBe` Nothing - it "supports empty input" $ + it "supports empty input" $ tokenizeOperators "" `shouldBe` Nothing describe "tokenizeIdentifier" $ do @@ -62,12 +62,12 @@ spec = do it "parses correct identifier with numbers" $ tokenizeIdentifier "someId14" `shouldBe` success (Identifier "someId14") 8 it "parses correct identifier with underscores" $ - tokenizeIdentifier "some_Id" `shouldBe` success (Identifier "some_Id") 7 - it "disallows to start identifier with underscore" $ + tokenizeIdentifier "some_Id" `shouldBe` success (Identifier "some_Id") 7 + it "disallows to start identifier with underscore" $ tokenizeIdentifier "_someId" `shouldBe` Nothing - it "disallows to start identifier with digit" $ + it "disallows to start identifier with digit" $ tokenizeIdentifier "5someId" `shouldBe` Nothing - it "supports empty input" $ + it "supports empty input" $ tokenizeIdentifier "" `shouldBe` Nothing describe "tokenizeWhitespace" $ do @@ -80,12 +80,12 @@ spec = do it "parses CR" $ tokenizeWhitespace "\r" `shouldBe` success WhiteSpace 1 it "rejects non-whitespace chars" $ do - let input = map (\x -> [x]) $ ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] - let expected = take (length input) . repeat $ Nothing + let input = map (: []) $ ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] + let expected = replicate (length input) Nothing map tokenizeWhitespace input `shouldBe` expected - it "supports empty input" $ - tokenizeIdentifier "" `shouldBe` Nothing - + it "supports empty input" $ + tokenizeIdentifier "" `shouldBe` Nothing + describe "tokenizeDecimal" $ do it "parses numbers from 0 to 65535" $ do let nums = [0 .. 65535] @@ -95,34 +95,34 @@ spec = do it "does not support negative numbers" $ do let nums = [-1, -2 .. -65535] :: [Integer] let input = map show nums - let expected = take (length nums) . repeat $ Nothing + let expected = replicate (length nums) Nothing map tokenizeDecimal input `shouldBe` expected it "rejects other input" $ - tokenizeDecimal "some unsupported input" `shouldBe` Nothing - it "supports empty input" $ - tokenizeDecimal "" `shouldBe` Nothing - + tokenizeDecimal "some unsupported input" `shouldBe` Nothing + it "supports empty input" $ + tokenizeDecimal "" `shouldBe` Nothing + describe "tokenizeHex" $ do it "parses numbers from 0x0 to 0xFFFF" $ do let nums = [0 .. 0xFFFF] - let input = map (("0x"++) . (flip showHex "")) nums - let expected = map (\n -> success (IntLiteral n) (length . ("0x"++) . (flip showHex "") $ n)) nums + let input = map (("0x"++) . flip showHex "") nums + let expected = map (\n -> success (IntLiteral n) (length . ("0x"++) . flip showHex "" $ n)) nums map tokenizeHex input `shouldBe` expected it "does not support negative numbers" $ do let nums = [0 .. 0xFFFF] :: [Integer] - let input = map (("-0x"++) . (flip showHex "")) nums - let expected = take (length nums) . repeat $ Nothing - map tokenizeHex input `shouldBe` expected + let input = map (("-0x"++) . flip showHex "") nums + let expected = replicate (length nums) Nothing + map tokenizeHex input `shouldBe` expected it "accepts left-padded number" $ tokenizeHex "0x0010" `shouldBe` success (IntLiteral 16) 6 it "rejects other input" $ - tokenizeHex "some unsupported input" `shouldBe` Nothing + tokenizeHex "some unsupported input" `shouldBe` Nothing it "rejects '0'" $ tokenizeHex "0" `shouldBe` Nothing it "rejects '0x'" $ - tokenizeHex "0x" `shouldBe` Nothing - it "supports empty input" $ - tokenizeHex "" `shouldBe` Nothing + tokenizeHex "0x" `shouldBe` Nothing + it "supports empty input" $ + tokenizeHex "" `shouldBe` Nothing describe "tokenizeChar" $ do it "parses letters literals" $ do @@ -134,13 +134,13 @@ spec = do let chars = ['0' .. '9'] let input = map (\c -> "'" ++ [c] ++ "'") 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 let chars = "!@#$%^&*()_+-=[]{};:|,/?<>\"" let input = map (\c -> "'" ++ [c] ++ "'") chars let expected = map (\c -> success (IntLiteral (ord c)) 3) chars - map tokenizeChar input `shouldBe` expected - it "parses escape sequences literals" $ do + map tokenizeChar input `shouldBe` expected + it "parses escape sequences literals" $ do let input = [ "'\\n'" , "'\\t'" , "'\\v'" @@ -162,7 +162,7 @@ spec = do tokenizeChar "'ab'" `shouldBe` Nothing it "rejects non-closed char literals" $ tokenizeChar "'a" `shouldBe` Nothing - it "rejects invalid escape sequences" $ + it "rejects invalid escape sequences" $ tokenizeChar "'\\x'" `shouldBe` Nothing it "rejects empty quotes" $ tokenizeChar "''" `shouldBe` Nothing @@ -185,9 +185,8 @@ spec = do let str = "!@2#$%9^&*(1)_s+2-=[2h6sh]t{};:'e|<>,./?" let len = length str + 2 let input = "\"" ++ str ++ "\"" - tokenizeString input `shouldBe` success (StringLiteral str) len - it "supports escape sequences literals" $ do - pendingWith "We need probably to fix tokenizeString since the following test fails" + tokenizeString input `shouldBe` success (StringLiteral str) len + it "supports escape sequences literals" $ pendingWith "We need probably to fix tokenizeString since the following test fails" -- TODO: -- let str = "\\n\\t\\v\\b\\r\\f\\a\\\\\\\"\\0" -- let len = length str + 2 @@ -207,18 +206,18 @@ spec = do it "rejects multilined strings" $ tokenizeString "\"first line\nsecond line\"" `shouldBe` Nothing it "supports empty input" $ - tokenizeString "" `shouldBe` Nothing - + tokenizeString "" `shouldBe` Nothing + describe "tokenizeComment" $ do - it "properly consumes comment" $ + it "properly consumes comment" $ tokenizeComment ";some comment\n" `shouldBe` success (Comment "some comment") 13 - it "properly consumes comment with whitespace padding" $ - tokenizeComment "; \t some comment \t \n \t" `shouldBe` success (Comment " \t some comment \t ") 22 + it "properly consumes comment with whitespace padding" $ + 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" $ 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 - 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 it "supports empty input" $ tokenizeComment "" `shouldBe` Nothing @@ -241,7 +240,7 @@ spec = do it "does not produce any token when the space is present instead" $ do let input = "abc " 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 let input = "abc-" let expected = success Colon 3 @@ -251,24 +250,24 @@ spec = do it "supports empty input irrespective of wrapped tokenizer" $ do let input = "" 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 it "returns the token if at least one subtokenizer produce that" $ do let values = [ success Ampersand 1 , 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 it "returns the token of the first matching subtokenizer" $ do let values = [ Nothing , Nothing , success (IntLiteral 4) 1 , Nothing - , Nothing + , Nothing , success (StringLiteral "not me") 8 , Nothing , success (StringLiteral "me neither") 12 @@ -279,19 +278,19 @@ spec = do , success Colon 1 , Nothing ] - let t = map (\x -> (\_ -> x)) values + let t = map const values anyTokenizer t "some not important input" `shouldBe` success (IntLiteral 4) 1 it "returns Nothing if no one of the tokenizers matches the input" $ do let values = [ 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 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 let input = "" let values = [ success Ampersand 1 @@ -299,47 +298,46 @@ spec = do , success (IntLiteral 3) 1 , success (Operator Push) 4 ] - let t = map (\x -> (\_ -> x)) values - anyTokenizer t input `shouldBe` Nothing + let t = map const values + anyTokenizer t input `shouldBe` Nothing - describe "tokenFilter" $ do - it "filters out whitespaces and comments" $ do - let tokens = [ Operator Push + describe "tokenFilter" $ it "filters out whitespaces and comments" $ do + 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 - , Comment "here is the identifier" , Identifier "someId" - , WhiteSpace , Colon - , WhiteSpace , Ampersand , NewLine - , WhiteSpace - , Comment "some comment" ] - let expected = [ Operator Push - , IntLiteral 4 - , Identifier "someId" - , Colon - , Ampersand - , NewLine - ] - filter tokenFilter tokens `shouldBe` expected + filter tokenFilter tokens `shouldBe` expected describe "tokenize" $ do it "treats 'pop' as a operator instead of identifier" $ tokenize "pop" `shouldBe` Right [Operator Pop] 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 let ops = [Nop ..] 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 it "treats operator-like names (with 's' appended) as identifiers" $ do let ops = [Nop ..] let input = map ((++"s") . show) ops - let expected = map (\i-> Right [Identifier i]) input - map tokenize input `shouldBe` expected + let expected = map (\i-> Right [Identifier i]) input + map tokenize input `shouldBe` expected it "treats '\n' as a newline instead of whitespace" $ tokenize "\n" `shouldBe` Right [NewLine] it "ignores comments" $ do @@ -355,11 +353,11 @@ spec = do it "accepts 'main: NL" $ tokenize ".main: \n" `shouldBe` Right [Dot, Identifier "main", Colon, NewLine] 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'" $ - tokenize "4push" `shouldBe` Left "Unknown token: 4push" - it "supports empty input" $ - tokenize "" `shouldBe` Right [] + tokenize "4push" `shouldBe` Left "Unknown token: 4push" + it "supports empty input" $ + tokenize "" `shouldBe` Right [] it "interprets example #1" $ do let input = "main: ; here we define some main label\n\ \ push 7 ; we push 7 to the stack\n\ @@ -377,5 +375,5 @@ spec = do , NewLine , Identifier "sum", Colon, Operator Add, NewLine , Operator Ret - ] - tokenize input `shouldBe` Right expected \ No newline at end of file + ] + tokenize input `shouldBe` Right expected \ No newline at end of file diff --git a/test/VirtualMachineSpec.hs b/test/VirtualMachineSpec.hs index c110f5b..1eb933e 100644 --- a/test/VirtualMachineSpec.hs +++ b/test/VirtualMachineSpec.hs @@ -741,14 +741,14 @@ spec = do let vm = empty { _stack = S.fromList [], _fp = 0 } let input = " ret \n\ \ 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 `shouldBe` expected 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 input = " ret \n\ \ 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 `shouldBe` expected @@ -790,7 +790,7 @@ spec = do it "raises error if stack is empty" $ do let input = " lda 0 \n\ \ 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 } actual <- exec vm input actual `shouldBe` expected @@ -798,14 +798,14 @@ spec = do let vm = empty { _stack = S.fromList [-1], _fp = 0 } let input = " lda 0 \n\ \ 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 `shouldBe` expected it "raises error if stack contains only previous fp and return address" $ do let vm = empty { _stack = S.fromList [2, -1], _fp = 0 } let input = " lda 0 \n\ \ 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 `shouldBe` expected 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 input = " lda 1 \n\ \ 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 `shouldBe` expected it "loads the 11th argument if it exists" $ do @@ -861,109 +861,7 @@ spec = do \ ret " let expected = done [25] 8 (-1) 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 - 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 it "pushes the second value from the top" $ do @@ -1017,7 +915,7 @@ spec = do \ push 3 \n\ \ ldl 0 \n\ \ halt " - let expected = Left "No active stack frame to load local variable" + let expected = Left "No active stack frame" actual <- run input actual `shouldBe` expected @@ -1040,7 +938,7 @@ spec = do \ push 3 \n\ \ stl 0 \n\ \ halt " - let expected = Left "No active stack frame to store local variable" + let expected = Left "No active stack frame" actual <- run input actual `shouldBe` expected