module Language.SSVM.Parser
(parseVM, parseSourceFile) where
import Data.Monoid
import qualified Data.Map as M
import Text.Parsec
import Text.Parsec.Token
import Text.Parsec.Language
import Language.SSVM.Types
baseLanguage = haskell
data ParserState = PState {
inDefinition :: Bool,
newWord :: Bool,
wordsCounter :: Int }
deriving (Eq, Show)
emptyState = PState {
inDefinition = False,
newWord = False,
wordsCounter = 0 }
type TParser a = Parsec String ParserState a
code :: [StackItem] -> TParser Code
code list = return $ Code [M.empty] list
startDefinition :: TParser ()
startDefinition = do
st <- getState
putState $ st {inDefinition = True, newWord = True}
endDefinition :: TParser ()
endDefinition = do
st <- getState
putState $ st {inDefinition = False, newWord = False}
pString :: TParser Code
pString = do
st <- getState
str <- stringLiteral baseLanguage
if newWord st
then do
putState $ st {newWord = False}
code [SString str]
else if inDefinition st
then code [Quote $ SString str]
else code [SString str]
pInteger :: TParser Code
pInteger = do
m <- optionMaybe (char '-')
digits <- many1 digit
let s = read digits
n = case m of
Nothing -> s
Just _ -> s
st <- getState
if inDefinition st
then code [Quote $ SInteger n]
else code [SInteger n]
addMark :: String -> TParser Code
addMark name = do
st <- getState
let addr = wordsCounter st
return $ Code [M.singleton name addr] []
instr :: Instruction -> TParser Code
instr i = do
st <- getState
if inDefinition st
then code [Quote (SInstruction i)]
else code [SInstruction i]
pWord :: TParser Code
pWord = do
word <- many1 (noneOf " \t\r\n")
case word of
"NOP" -> instr NOP
"DROP" -> instr DROP
"DUP" -> instr DUP
"SWAP" -> instr SWAP
"OVER" -> instr OVER
"." -> instr PRINT
".." -> instr PRINTALL
"+" -> instr ADD
"-" -> instr SUB
"*" -> instr MUL
"/" -> instr DIV
"REM" -> instr REM
"NEG" -> instr NEG
"ABS" -> instr ABS
"CMP" -> instr CMP
";" -> endDefinition >> code [SInstruction DEFINE]
":" -> startDefinition >> code [SInstruction COLON]
"VARIABLE" -> endDefinition >> code [SInstruction VARIABLE]
"!" -> instr ASSIGN
"@" -> instr READ
"INPUT" -> instr INPUT
"MARK" -> instr MARK
"GOTO" -> instr GOTO
"JZ" -> instr JZ
"JNZ" -> instr JNZ
"JGT" -> instr JGT
"JLT" -> instr JLT
"JGE" -> instr JGE
"JLE" -> instr JLE
"ARRAY" -> instr ARRAY
"[@]" -> instr READ_ARRAY
"[!]" -> instr ASSIGN_ARRAY
_ | head word == '@' -> instr (GETMARK $ tail word)
| otherwise -> do
st <- getState
if newWord st
then do
putState $ st {newWord = False}
code [SString word]
else if inDefinition st
then code [Quote $ SInstruction $ CALL word]
else code [SInstruction $ CALL word]
pLabel :: TParser Code
pLabel = do
char '.'
name <- many1 (noneOf ". \t\r\n")
addMark name
step :: Int -> TParser ()
step k = do
st <- getState
putState $ st {wordsCounter = k + wordsCounter st}
pSpaces :: TParser Code
pSpaces = do
many1 (oneOf " \t\r\n")
code []
pSource :: TParser Code
pSource = do
ws <- many1 anyWord
return (mconcat ws)
where
anyWord = do
word <- (try pSpaces <|> try pString <|> try pInteger <|> try pLabel <|> pWord)
step (length $ cCode word)
return word
parseVM :: FilePath -> String -> Either ParseError Code
parseVM name str = runParser pSource emptyState name str
parseSourceFile :: FilePath -> IO (Either ParseError Code)
parseSourceFile path = do
str <- readFile path
return $ runParser pSource emptyState path str