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

Resolve compilation warnings

Browse Source
This commit is contained in:
Bartłomiej Przemysław Pluta
2021-11-08 10:36:22 +01:00
parent 919cddd814
commit 42b2eb5e41
6 changed files with 80 additions and 84 deletions
Download Patch File Download Diff File Expand all files Collapse all files

14
app/Assembler/Parser.hs
View File

@@ -38,7 +38,7 @@ parseInt _ = Nothing
-- ID := [alnum, '_']+
parseIdentifier :: Parser
parseIdentifier ((T.Identifier id):_) = Just $ ParseResult (Identifier id) 1
parseIdentifier ((T.Identifier iden):_) = Just $ ParseResult (Identifier iden) 1
parseIdentifier _ = Nothing
-- ':'
@@ -54,12 +54,12 @@ parseAmpersand _ = Nothing
-- label_def := ID ':'
parseLabelDef :: Parser
parseLabelDef = parseSeq [parseIdentifier, parseColon] combine
where combine = (\[(Identifier id), _] -> LabelDef id)
where combine = (\[(Identifier iden), _] -> LabelDef iden)
-- label_ref := '&' ID
parseLabelRef :: Parser
parseLabelRef = parseSeq [parseAmpersand, parseIdentifier] combine
where combine = (\[_, (Identifier id)] -> LabelRef id)
where combine = (\[_, (Identifier iden)] -> LabelRef iden)
-- param := INT | label_ref
parseParam :: Parser
@@ -103,7 +103,7 @@ parseMany parser combiner tokens = if null asts
-- a a a a a a a...
parseGreedy :: Parser -> [T.Token] -> [ParseResult]
parseGreedy parser tokens = case parser tokens of
(Just r@(ParseResult ast consumed)) -> r : parseGreedy parser (drop consumed tokens)
(Just r@(ParseResult _ consumed)) -> r : parseGreedy parser (drop consumed tokens)
Nothing -> []
-- a | b | c
@@ -147,9 +147,9 @@ assertConsumed parser tokens = do
parse :: [T.Token] -> Either String AST
parse tokens = do
let lines = U.explode (==T.NewLine) tokens
let results = map (assertConsumed parseLine) lines
let errors = filter ((==Nothing) . snd) $ zipWith (,) lines $ results
let codeLines = U.explode (==T.NewLine) tokens
let results = map (assertConsumed parseLine) codeLines
let errors = filter ((==Nothing) . snd) $ zipWith (,) codeLines $ results
let errorMsg = "Parse error(s):\n" ++ (List.intercalate "\n" $ map (show . fst) errors)
case sequenceA results of
(Just r) -> return $ Program $ map (\(ParseResult ast _) -> ast) r

44
app/Assembler/Tokenizer.hs
View File

@@ -90,10 +90,10 @@ tokenizeString ('"':xs) = do
return $ TokenizeResult (StringLiteral unescaped) (length string + 2)
where
extractString [] = Nothing
extractString (x:xs)
| x == '"' = Just []
| x == '\n' = Nothing
| otherwise = extractString xs >>= (\r -> return $ x : r)
extractString (y:ys)
| y == '"' = Just []
| y == '\n' = Nothing
| otherwise = extractString ys >>= (\r -> return $ y : r)
tokenizeString _ = Nothing
tokenizeComment :: Tokenizer
@@ -108,12 +108,12 @@ tokenizeComment (x:xs) = if x == ';'
type SeparatorPredicate = Char -> Bool
sepTokenizer :: SeparatorPredicate -> Tokenizer -> Tokenizer
sepTokenizer _ _ [] = Nothing
sepTokenizer pred tokenizer input = do
result@(TokenizeResult token consumed) <- tokenizer input
sepTokenizer predicate tokenizer input = do
result@(TokenizeResult _ consumed) <- tokenizer input
let next = drop consumed input
let (isSep, _) = if null next
then (True, 0)
else if pred . head $ next
else if predicate . head $ next
then (True, 1)
else (False, 0)
if isSep
@@ -131,23 +131,21 @@ tokenize input = tokens >>= (\t -> Right $ filter tokenFilter t)
tokens = case tokenizers input of
(Just (TokenizeResult token chars)) -> tokenize (drop chars input) >>= (\rest -> return $ token : rest)
Nothing -> Left $ "Unknown token: " ++ take 20 input
tokenizers = anyTokenizer
[ keywordTokenizer False "\n" NewLine
, tokenizeWhitespace
, tokenizeComment
, sepTokenizer Char.isSpace tokenizeOperators
, sepTokenizer Char.isSpace tokenizeHex
, sepTokenizer Char.isSpace tokenizeDecimal
, tokenizeIdentifier
, keywordTokenizer False ":" Colon
, keywordTokenizer False "&" Ampersand
, tokenizeChar
, tokenizeString
]
tokenFilter :: Token -> Bool
tokenFilter (WhiteSpace) = False
tokenFilter (Comment _) = False
tokenFilter _ = True
tokenizers :: Tokenizer
tokenizers = anyTokenizer
[ keywordTokenizer False "\n" NewLine
, tokenizeWhitespace
, tokenizeComment
, sepTokenizer Char.isSpace tokenizeOperators
, sepTokenizer Char.isSpace tokenizeHex
, sepTokenizer Char.isSpace tokenizeDecimal
, tokenizeIdentifier
, keywordTokenizer False ":" Colon
, keywordTokenizer False "&" Ampersand
, tokenizeChar
, tokenizeString
]
tokenFilter _ = True

12
app/Util.hs
View File

@@ -21,14 +21,14 @@ bytesStr :: Int -> [Word8] -> String
bytesStr sparse = insertAtN '\n' (sparse*3) . intercalate " " . map byteStr
byteStr :: Word8 -> String
byteStr = pad '0' 2 . (flip showHex) "" . fromIntegral
byteStr = pad '0' 2 . (flip showHex) "" . (fromIntegral :: Word8 -> Integer)
insertAtN :: a -> Int -> [a] -> [a]
insertAtN c n xs = insertAtN' n xs
where
insertAtN' 0 xs = c : insertAtN' n xs
insertAtN' 0 ys = c : insertAtN' n ys
insertAtN' _ [] = []
insertAtN' m (x:xs) = x : insertAtN' (m-1) xs
insertAtN' m (y:ys) = y : insertAtN' (m-1) ys
pad :: Char -> Int -> String -> String
pad char width string = replicate (width - length string) char ++ string
@@ -61,8 +61,8 @@ controlChar x = case x of
_ -> Nothing
explode :: (Foldable f) => (a -> Bool) -> f a -> [[a]]
explode pred xs = filter (not . null) $ foldr split [[]] xs
explode predicate xs = filter (not . null) $ foldr split [[]] xs
where
split y (ys:yss)
| pred y = []:ys:yss
| otherwise = (y:ys):yss
| predicate y = []:ys:yss
| otherwise = (y:ys):yss

92
app/VirtualMachine.hs
View File

@@ -19,10 +19,10 @@ import qualified Data.ByteString as B
import qualified Util as U
data VM = VM { pc :: Int
, fp :: Int
, stack :: S.Seq Int
, halt :: Bool
data VM = VM { _pc :: Int
, _fp :: Int
, _stack :: S.Seq Int
, _halt :: Bool
} deriving (Show, Eq)
data Op = Nop -- 0x00
@@ -53,57 +53,57 @@ type Args = [Int]
type Pops = [Int]
type Pushes = S.Seq Int
data Instruction = Simple { op :: Op
, noParams :: Int
, noPops :: Int
, sAction :: Args -> Pops -> Pushes
data Instruction = Simple { _op :: Op
, _noParams :: Int
, _noPops :: Int
, _sAction :: Args -> Pops -> Pushes
}
| Complex { op :: Op
, noParams :: Int
, cAction :: VM -> Args -> Either String VM
| Complex { _op :: Op
, _noParams :: Int
, _cAction :: VM -> Args -> Either String VM
}
data Command = Command { instr :: Instruction
, args :: [Int]
data Command = Command { _instr :: Instruction
, _args :: [Int]
}
empty :: VM
empty = VM { pc = 0
, fp = -1
, stack = S.empty
, halt = False
empty = VM { _pc = 0
, _fp = -1
, _stack = S.empty
, _halt = False
}
instructions :: [Instruction]
instructions = [ Simple { op = Nop, noParams = 0, noPops = 0, sAction = (\_ _ -> S.empty) }
, Simple { op = Push, noParams = 1, noPops = 0, sAction = (\args _ -> S.fromList args) }
, 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]) }
, Complex { op = Halt, noParams = 0, cAction = (\vm _ -> Right $ vm { halt = True }) }
, Complex { op = Jmp, noParams = 1, cAction = (\vm [x] -> Right $ vm { pc = x}) }
, Complex { op = Je, noParams = 1, cAction = jumpIf (==) }
, Complex { op = Jne, noParams = 1, cAction = jumpIf (/=) }
, Complex { op = Jg, noParams = 1, cAction = jumpIf (>) }
, Complex { op = Jl, noParams = 1, cAction = jumpIf (<) }
, Complex { op = Jge, noParams = 1, cAction = jumpIf (>=) }
, Complex { op = Jle, noParams = 1, cAction = jumpIf (<=) }
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]) }
, Complex { _op = Halt, _noParams = 0, _cAction = (\vm _ -> Right $ vm { _halt = True }) }
, Complex { _op = Jmp, _noParams = 1, _cAction = (\vm [x] -> Right $ vm { _pc = x}) }
, Complex { _op = Je, _noParams = 1, _cAction = jumpIf (==) }
, Complex { _op = Jne, _noParams = 1, _cAction = jumpIf (/=) }
, Complex { _op = Jg, _noParams = 1, _cAction = jumpIf (>) }
, Complex { _op = Jl, _noParams = 1, _cAction = jumpIf (<) }
, Complex { _op = Jge, _noParams = 1, _cAction = jumpIf (>=) }
, Complex { _op = Jle, _noParams = 1, _cAction = jumpIf (<=) }
]
jumpIf :: (Int -> Int -> Bool) -> VM -> Args -> Either String VM
jumpIf predicate vm [addr] = Right $ vm { pc = pc' }
jumpIf predicate vm [addr] = Right $ vm { _pc = pc }
where
(top:_) = toList . stack $ vm
pc' = if top `predicate` 0 then addr else pc vm + 1
(top:_) = toList . _stack $ vm
pc = if top `predicate` 0 then addr else _pc vm + 1
instructionByOp :: Map.Map Op Instruction
instructionByOp = Map.fromList $ map (\i -> (op i, i)) instructions
instructionByOp = Map.fromList $ map (\i -> (_op i, i)) instructions
toOp :: String -> Op
toOp = read . capitalize
@@ -125,7 +125,7 @@ parseCommand [] = Nothing
parseCommand (opByte:xs) = do
let op = toEnum . fromIntegral $ opByte :: Op
instruction <- Map.lookup op instructionByOp
let paramsNumber = noParams instruction
let paramsNumber = _noParams instruction
let params = map fromIntegral $ take paramsNumber xs :: [Int]
return (Command instruction params, drop paramsNumber xs)
@@ -138,19 +138,19 @@ interpret cmds vm = do
interpretCommand :: [Command] -> VM -> Either String VM
interpretCommand [] _ = Left $ "Empty code"
interpretCommand cmds vm@(VM pc _ _ _)
| pc >= length cmds = Right $ vm { halt = True }
| pc >= length cmds = Right $ vm { _halt = True }
| otherwise = case instr of
(Simple _ _ _ _) -> interpretSimple vm cmd
(Complex _ _ _) -> interpretComplex vm cmd
where cmd@(Command instr _) = cmds !! pc
interpretSimple :: VM -> Command -> Either String VM
interpretSimple vm (Command (Simple op _ noPops operation) args) = vm'
interpretSimple vm (Command (Simple _ _ noPops operation) args) = vm'
where
pops = toList . S.take noPops . stack $ vm
pops = toList . S.take noPops . _stack $ vm
stack' = Right $ operation args pops
vm' = stack' >>= (\s -> Right $ vm { pc = pc vm + 1
, stack = s <> (S.drop noPops . stack) vm
vm' = stack' >>= (\s -> Right $ vm { _pc = _pc vm + 1
, _stack = s <> (S.drop noPops . _stack) vm
})
interpretSimple _ _ = Left "Unknown operation"

1
test/Assembler/ParserSpec.hs
View File

@@ -1,7 +1,6 @@
module Assembler.ParserSpec where
import Test.Hspec
import Test.Hspec.QuickCheck
import qualified Assembler.Tokenizer as T
import Assembler.Parser

1
test/Assembler/TokenizerSpec.hs
View File

@@ -1,7 +1,6 @@
module Assembler.TokenizerSpec where
import Test.Hspec
import Test.Hspec.QuickCheck
import Numeric (showHex)
import Data.Char (ord)