diff --git a/app/Assembler/Emitter.hs b/app/Assembler/Emitter.hs index eb2f7c4..d8e7167 100644 --- a/app/Assembler/Emitter.hs +++ b/app/Assembler/Emitter.hs @@ -10,10 +10,12 @@ import Data.Word (Word8) import qualified Data.Map as M import Assembler.Parser (AST(..), Scope(..)) +import Data.Functor ((<&>)) +import Util (maybeToExcept, maybeToEither) -data Bean = Byte Word8 - | Reference String +data Bean = Byte { _byte :: Word8 } + | Reference { _reference :: String } deriving (Show, Eq) data Context = Context { _beans :: [Bean] @@ -29,7 +31,6 @@ emitBean :: Bean -> ExceptT String (State Context) () emitBean bean = lift $ do ctx <- get put ctx { _beans = _beans ctx ++ [bean] } - return () emitByte :: Word8 -> ExceptT String (State Context) () emitByte byte = emitBean $ Byte byte @@ -39,9 +40,7 @@ emitParam (Param (Integer x)) = emitByte $ fromIntegral x emitParam (Param (LabelRef Global l)) = emitBean $ Reference l emitParam (Param (LabelRef Local l)) = do ctx <- lift get - scope <- case _currentLabel ctx of - (Just s) -> return s - Nothing -> throwError $ "Local label ('." ++ l ++ "') reference is allowed only in the global label scope" + scope <- maybeToExcept (_currentLabel ctx) $ "Local label ('." ++ l ++ "') reference is allowed only in the global label scope" emitBean $ Reference (scope ++ "." ++ l) emitParam _ = throwError "Number or label reference expected" @@ -52,31 +51,25 @@ emitLabelDef (LabelDef Global label) = do let current = length (_beans ctx) when (label `M.member` labels) (throwError $ "Label '" ++ label ++ "' is already defined") put ctx { _labels = M.insert label current labels, _currentLabel = Just label } - return () emitLabelDef (LabelDef Local label) = do ctx <- lift get let labels = _labels ctx - scope <- case _currentLabel ctx of - (Just s) -> return s - Nothing -> throwError $ "Local label ('." ++ label ++ "') can be defined only in the global label scope" + scope <- maybeToExcept (_currentLabel ctx) $ "Local label ('." ++ label ++ "') can be defined only in the global label scope" let canonicalLabel = scope ++ "." ++ label let current = length (_beans ctx) when (canonicalLabel `M.member` labels) (throwError $ "Label '" ++ label ++ "' is already defined in the global label '" ++ scope ++ "' scope") put ctx { _labels = M.insert canonicalLabel current labels } - return () emitLabelDef _ = throwError "Label definition expected" emitInstr :: Emitter emitInstr (Instruction (Operator op) Empty) = emitByte $ fromIntegral . fromEnum $ op -emitInstr (Instruction (Operator op) (Params params)) = do - emitByte $ fromIntegral $ fromEnum op - mapM_ emitParam params +emitInstr (Instruction (Operator op) (Params params)) = emitByte (fromIntegral $ fromEnum op) >> mapM_ emitParam params emitInstr _ = throwError "Instruction expected" emitLine :: Emitter emitLine (Line labelDef Empty) = emitLabelDef labelDef emitLine (Line Empty instr) = emitInstr instr -emitLine (Line labelDef instr) = emitLabelDef labelDef >> emitInstr instr >> return () +emitLine (Line labelDef instr) = emitLabelDef labelDef >> emitInstr instr emitLine _ = throwError "Line of code expected" emitProgram :: Emitter @@ -85,21 +78,14 @@ emitProgram _ = throwError "Program code expected" resolveLabels :: M.Map String Int -> [Bean] -> Either String [Bean] resolveLabels labels beans = sequence $ foldr folder [] beans - where - folder b acc = resolveLabel labels b : acc + where 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" +resolveLabel labels (Reference label) = Byte . fromIntegral <$> maybeToEither (M.lookup label labels) ("Label '" ++ label ++ "' is not defined") + emit :: AST -> Either String [Word8] -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 +emit root = evalState (runExceptT $ emitProgram root >> lift get) empty >>= \ctx -> resolveLabels (_labels ctx) (_beans ctx) <&> map _byte \ No newline at end of file diff --git a/app/Assembler/Parser.hs b/app/Assembler/Parser.hs index 104322b..957b130 100644 --- a/app/Assembler/Parser.hs +++ b/app/Assembler/Parser.hs @@ -6,7 +6,8 @@ import Data.Monoid (First(..)) import qualified Assembler.Tokenizer as T (Token(..)) import VirtualMachine.VM (Op) -import Util (explode) +import Util (explode, maybeToEither) +import Control.Monad (guard) data Scope = Local | Global deriving (Eq, Show, Enum, Bounded) @@ -27,7 +28,9 @@ data AST = Empty deriving (Eq, Show) type ConsumedTokens = Int -data ParseResult = ParseResult AST ConsumedTokens deriving (Eq, Show) +data ParseResult = ParseResult { _ast :: AST + , _consumed :: ConsumedTokens + } deriving (Eq, Show) type Parser = [T.Token] -> Maybe ParseResult @@ -64,16 +67,14 @@ parseDot _ = Nothing -- label_def := '.'? ID ':' parseLabelDef :: Parser parseLabelDef = parseSeq [parseOptionally parseDot, parseIdentifier, parseColon] combine - where - combine [Dot, Identifier iden, _] = LabelDef Local iden - combine [_, Identifier iden, _] = LabelDef Global iden + where 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 + where combine [_, Dot, Identifier iden] = LabelRef Local iden + combine [_, _, Identifier iden] = LabelRef Global iden -- param := INT | label_ref parseParam :: Parser @@ -89,9 +90,7 @@ parseLine = parseSeq [parseOptionally parseLabelDef, parseOptionally parseInstr] mapAST :: Parser -> (AST -> AST) -> Parser mapAST _ _ [] = Nothing -mapAST parser mapper tokens = do - (ParseResult ast consumed) <- parser tokens - return $ ParseResult (mapper ast) consumed +mapAST parser mapper tokens = parser tokens >>= \(ParseResult ast consumed) -> return $ ParseResult (mapper ast) consumed -- a? parseOptionally :: Parser -> Parser @@ -105,14 +104,11 @@ parseMany0 parser combiner = parseOptionally $ parseMany parser combiner -- a+ parseMany :: Parser -> ([AST] -> AST) -> Parser -parseMany parser combiner tokens = if null asts - then Nothing - else Just $ ParseResult ast consumed - where - results = parseGreedy parser tokens - consumed = sum $ map (\(ParseResult _ c) -> c) results - asts = map (\(ParseResult a _) -> a) results - ast = combiner asts +parseMany parser combiner tokens = guard (not $ null asts) >> return (ParseResult ast consumed) + where results = parseGreedy parser tokens + consumed = sum $ map _consumed results + asts = map _ast results + ast = combiner asts -- a a a a a a a... parseGreedy :: Parser -> [T.Token] -> [ParseResult] @@ -136,11 +132,10 @@ parseSeq :: [Parser] -> ([AST] -> AST) -> Parser parseSeq _ _ [] = Nothing parseSeq parsers combiner tokens = do results <- parseAll parsers tokens - let consumed = sum $ map (\(ParseResult _ c) -> c) results - let asts = map (\(ParseResult a _) -> a) results - if length asts == length parsers - then return $ ParseResult (combiner asts) consumed - else Nothing + let consumed = sum $ map _consumed results + let asts = map _ast results + guard $ length asts == length parsers + return $ ParseResult (combiner asts) consumed -- a b c parseAll :: [Parser] -> [T.Token] -> Maybe [ParseResult] @@ -153,11 +148,7 @@ parseAll (p:ps) tokens = do -- 'Nothing' if not consumed tokens exist assertConsumed :: Parser -> Parser assertConsumed _ [] = Nothing -assertConsumed parser tokens = do - r@(ParseResult _ consumed) <- parser tokens - if null (drop consumed tokens) - then return r - else Nothing +assertConsumed parser tokens = parser tokens >>= \r@(ParseResult _ consumed) -> guard (null $ drop consumed tokens) >> return r parse :: [T.Token] -> Either String AST parse tokens = do @@ -165,6 +156,4 @@ parse tokens = do let results = map (assertConsumed parseLine) codeLines let errors = filter ((==Nothing) . snd) $ zip codeLines results let errorMsg = "Parse error(s):\n" ++ intercalate "\n" (map (show . fst) errors) - case sequenceA results of - (Just r) -> return $ Program $ map (\(ParseResult ast _) -> ast) r - Nothing -> Left errorMsg \ No newline at end of file + Program . map _ast <$> maybeToEither (sequenceA results) errorMsg \ No newline at end of file diff --git a/app/Assembler/Tokenizer.hs b/app/Assembler/Tokenizer.hs index e1e7417..9fa1f14 100644 --- a/app/Assembler/Tokenizer.hs +++ b/app/Assembler/Tokenizer.hs @@ -5,7 +5,8 @@ import Data.Char (ord, isDigit, isSpace, isAlpha, isAlphaNum, isHexDigit) import Data.Monoid (First(..)) import VirtualMachine.VM (Op(..)) -import Util (toLowerCase, controlChar, unescape) +import Util (toLowerCase, controlChar, unescape, maybeToEither) +import Control.Monad (guard) data Token = Operator Op @@ -28,14 +29,10 @@ type Tokenizer = String -> Maybe TokenizeResult type CaseSensitive = Bool keywordTokenizer :: CaseSensitive -> String -> Token -> Tokenizer keywordTokenizer _ _ _ [] = Nothing -keywordTokenizer cs kwd token input - | matches = Just $ TokenizeResult token len - | otherwise = Nothing - where - len = length kwd - mapper = if cs then id else toLowerCase - zipped = zipWith (==) (mapper kwd) (mapper . take len $ input) - matches = and zipped && len == length zipped +keywordTokenizer cs kwd token input = guard matches >> return (TokenizeResult token len) + where len = length kwd + matches = mapper kwd == mapper (take len input) + mapper = if cs then id else toLowerCase operatorTokenizer :: Op -> Tokenizer operatorTokenizer op = keywordTokenizer False (toLowerCase . show $ op) (Operator op) @@ -46,37 +43,29 @@ tokenizeOperators = anyTokenizer $ map operatorTokenizer $ sortBy cmp [Nop ..] tokenizeIdentifier :: Tokenizer tokenizeIdentifier [] = Nothing -tokenizeIdentifier input@(x:_) = if null identifier || (not . isAlpha) x - then Nothing - else Just $ TokenizeResult (Identifier identifier) (length identifier) +tokenizeIdentifier input@(x:_) = guard (not $ null identifier) >> guard (isAlpha x) >> return token where identifier = takeWhile (or . sequenceA [isAlphaNum, (=='_')]) input + token = TokenizeResult (Identifier identifier) (length identifier) tokenizeWhitespace :: Tokenizer tokenizeWhitespace [] = Nothing -tokenizeWhitespace (x:_) - | isSpace x = Just $ TokenizeResult WhiteSpace 1 - | otherwise = Nothing +tokenizeWhitespace (x:_) = guard (isSpace x) >> return (TokenizeResult WhiteSpace 1) tokenizeDecimal :: Tokenizer tokenizeDecimal [] = Nothing -tokenizeDecimal input = if null numberStr - then Nothing - else Just $ TokenizeResult (IntLiteral number) len - where - number = read numberStr - len = length numberStr - numberStr = takeWhile isDigit input +tokenizeDecimal input = guard (not $ null numberStr) >> return token + where numberStr = takeWhile isDigit input + token = TokenizeResult (IntLiteral $ read numberStr) $ length numberStr tokenizeHex :: Tokenizer -tokenizeHex ('0':'x':input) = if null input - then Nothing - else Just $ TokenizeResult (IntLiteral $ read $ "0x" ++ numberStr) (length numberStr + 2) +tokenizeHex ('0':'x':input) = guard (not $ null numberStr) >> return token where numberStr = takeWhile isHexDigit input + token = TokenizeResult (IntLiteral $ read $ "0x" ++ numberStr) (length numberStr + 2) tokenizeHex _ = Nothing tokenizeChar :: Tokenizer -tokenizeChar ('\'':'\\':x:'\'':_) = controlChar x >>= (\s -> return $ TokenizeResult (IntLiteral s) 4) -tokenizeChar ('\'':x:'\'':_) = Just $ TokenizeResult (IntLiteral . ord $ x) 3 +tokenizeChar ('\'':'\\':x:'\'':_) = controlChar x >>= \s -> return $ TokenizeResult (IntLiteral s) 4 +tokenizeChar ('\'':x:'\'':_) = return $ TokenizeResult (IntLiteral . ord $ x) 3 tokenizeChar _ = Nothing tokenizeString :: Tokenizer @@ -89,11 +78,11 @@ tokenizeString ('"':xs) = do extractString (y:ys) | y == '"' = Just [] | y == '\n' = Nothing - | otherwise = extractString ys >>= (\r -> return $ y : r) + | otherwise = (y:) <$> extractString ys tokenizeString _ = Nothing tokenizeComment :: Tokenizer -tokenizeComment (';':xs) = Just $ TokenizeResult (Comment comment) (length comment + 1) +tokenizeComment (';':xs) = return $ TokenizeResult (Comment comment) (length comment + 1) where comment = takeWhile (/='\n') xs tokenizeComment _ = Nothing @@ -103,9 +92,8 @@ sepTokenizer _ _ [] = Nothing sepTokenizer predicate tokenizer input = do result@(TokenizeResult _ consumed) <- tokenizer input let next = drop consumed input - if null next || (predicate . head $ next) - then return result - else Nothing + guard $ null next || (predicate . head $ next) + return result anyTokenizer :: [Tokenizer] -> Tokenizer anyTokenizer _ [] = Nothing @@ -113,27 +101,24 @@ anyTokenizer tokenizers input = getFirst . mconcat . map First $ sequenceA token tokenize :: String -> Either String [Token] tokenize [] = Right [] -tokenize input = tokens >>= (Right . filter tokenFilter) - where - 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 isSpace tokenizeOperators - , sepTokenizer isSpace tokenizeHex - , sepTokenizer isSpace tokenizeDecimal - , tokenizeIdentifier - , keywordTokenizer False ":" Colon - , keywordTokenizer False "&" Ampersand - , keywordTokenizer False "." Dot - , tokenizeChar - , tokenizeString - ] +tokenize input = tokens >>= (\(TokenizeResult token chars) -> (token:) <$> tokenize (drop chars input)) >>= (Right . filter tokenFilter) + where tokens = maybeToEither (tokenizers input) $ "Unknown token: " ++ take 20 input + tokenizers = anyTokenizer + [ keywordTokenizer False "\n" NewLine + , tokenizeWhitespace + , tokenizeComment + , sepTokenizer isSpace tokenizeOperators + , sepTokenizer isSpace tokenizeHex + , sepTokenizer isSpace tokenizeDecimal + , tokenizeIdentifier + , keywordTokenizer False ":" Colon + , keywordTokenizer False "&" Ampersand + , keywordTokenizer False "." Dot + , tokenizeChar + , tokenizeString + ] tokenFilter :: Token -> Bool -tokenFilter WhiteSpace = False -tokenFilter (Comment _) = False -tokenFilter _ = True \ No newline at end of file +tokenFilter WhiteSpace = False +tokenFilter (Comment _) = False +tokenFilter _ = True diff --git a/app/Main.hs b/app/Main.hs index 5056729..1e0e6a9 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -10,6 +10,5 @@ main = do input <- readFile filename result <- run input case result of - (Right vm) -> do - putStrLn $ "\nDone\n" ++ show vm + (Right vm) -> putStrLn $ "\n\nDone. \n" ++ show vm (Left err) -> putStrLn $ "\n\nError:\n" ++ err diff --git a/app/Util.hs b/app/Util.hs index 969f605..5489b44 100644 --- a/app/Util.hs +++ b/app/Util.hs @@ -5,13 +5,16 @@ module Util ( head, unescape, controlChar, - explode + explode, + maybeToExcept, + maybeToEither ) where import Prelude hiding (head) import Data.Word (Word8) import Data.Char (chr, toLower) import Numeric (showHex) +import Control.Monad.Except (MonadError (throwError)) toLowerCase :: String -> String @@ -25,10 +28,9 @@ byteStr = pad '0' 2 . flip showHex "" . (fromIntegral :: Word8 -> Integer) insertAtN :: a -> Int -> [a] -> [a] insertAtN c n xs = insertAtN' n xs - where - insertAtN' 0 ys = c : insertAtN' n ys - insertAtN' _ [] = [] - insertAtN' m (y:ys) = y : insertAtN' (m-1) ys + where insertAtN' 0 ys = c : insertAtN' n ys + insertAtN' _ [] = [] + insertAtN' m (y:ys) = y : insertAtN' (m-1) ys pad :: Char -> Int -> String -> String pad char width string = replicate (width - length string) char ++ string @@ -38,11 +40,8 @@ head [] = Nothing head (x:_) = Just x unescape :: String -> Maybe String -unescape ('\\':x:xs) = do - cc <- chr <$> controlChar x - rest <- unescape xs - return $ cc : rest -unescape (x:xs) = unescape xs >>= (\rest -> return $ x : rest) +unescape ('\\':x:xs) = (:) . chr <$> controlChar x <*> unescape xs +unescape (x:xs) = (x:) <$> unescape xs unescape [] = Just [] controlChar :: Char -> Maybe Int @@ -62,8 +61,17 @@ controlChar x = case x of explode :: (Foldable f) => (a -> Bool) -> f a -> [[a]] explode predicate xs = filter (not . null) $ foldr split [[]] xs - where - split _ [] = [] - split y (ys:yss) - | predicate y = []:ys:yss - | otherwise = (y:ys):yss \ No newline at end of file + where split _ [] = [] + split y (ys:yss) + | predicate y = []:ys:yss + | otherwise = (y:ys):yss + +maybeToEither :: Maybe a -> e -> Either e a +maybeToEither m err = case m of + (Just x) -> Right x + Nothing -> Left err + +maybeToExcept :: MonadError e m => Maybe a -> e -> m a +maybeToExcept m err = case m of + (Just x) -> return x + Nothing -> throwError err \ No newline at end of file diff --git a/app/VirtualMachine/Interpreter.hs b/app/VirtualMachine/Interpreter.hs index 92c02b7..fa2eab8 100644 --- a/app/VirtualMachine/Interpreter.hs +++ b/app/VirtualMachine/Interpreter.hs @@ -13,14 +13,13 @@ import qualified Data.ByteString as B import VirtualMachine.VM (VM(..), Op, Computation, get, pop, pushS, forward, getPc, isHalted, isDebug) import VirtualMachine.Instruction (Instruction(..), Unit(..), instructionByOp) +import Util (maybeToEither) parseInstr :: [Word8] -> Either String (Instruction, [Word8]) parseInstr (opCode:rest) = do let op = toEnum . fromIntegral $ opCode :: Op - instr <- case M.lookup op instructionByOp of - (Just i) -> Right i - Nothing -> Left "Unknown instruction" + instr <- maybeToEither (M.lookup op instructionByOp) "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 ++ "'") diff --git a/app/VirtualMachine/VM.hs b/app/VirtualMachine/VM.hs index a8c9e52..3e6917d 100644 --- a/app/VirtualMachine/VM.hs +++ b/app/VirtualMachine/VM.hs @@ -10,6 +10,7 @@ import qualified Data.Sequence as S import qualified Control.Monad.State as ST (get, put) import Data.Functor ((<&>)) import Control.Monad (unless) +import Util (maybeToExcept) data VM = VM { _pc :: Int @@ -85,9 +86,7 @@ isDebug :: Computation Bool isDebug = get <&> _debug stackAt :: Int -> String -> Computation Int -stackAt index err = get >>= \vm -> case _stack vm S.!? index of - (Just i) -> return i - Nothing -> throwError err +stackAt index err = get >>= \vm -> maybeToExcept (_stack vm S.!? index) err frameAt :: Int -> (Int -> Int) -> String -> Computation Int frameAt index t name = do @@ -95,9 +94,7 @@ frameAt index t name = do fp <- getFp unless (fp > -1) (throwError "No active stack frame") stackSize <- getStackSize - case _stack vm S.!? (stackSize - fp - 1 - t index) of - (Just i) -> return i - Nothing -> throwError $ "Cannot determine " ++ name ++ " - index " ++ show index ++ " out of frame bounds" + maybeToExcept (_stack vm S.!? (stackSize - fp - 1 - t index)) $ "Cannot determine " ++ name ++ " - index " ++ show index ++ " out of frame bounds" updateFrameAt :: Int -> Int -> Computation () updateFrameAt index value = do