Improve code

2021-11-19 17:07:18 +01:00
parent 2c56582460
commit 2737e0a34e
7 changed files with 101 additions and 138 deletions
--- 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

  
--- 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
+  Program . map _ast <$> maybeToEither (sequenceA results) errorMsg
--- 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
+tokenFilter WhiteSpace  = False
+tokenFilter (Comment _) = False
+tokenFilter _           = True
--- 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
--- 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 
+  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
--- 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 ++ "'")
--- 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