+module Expr_eval (expr, testExpr) where
+import DTFormat
+
+import Text.Printf
+import Text.Parsec.String
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language
import System.IO
+import Data.Word
+import Data.Bits
lexer :: P.TokenParser ()
-lexer = P.makeTokenParser (haskellDef { reservedOpNames = ["*","/","+","-","**"] })
-
-naturalOrFloat = P.naturalOrFloat lexer
-parens = P.parens lexer
-reservedOp = P.reservedOp lexer
-
-expr :: Parser Double
-expr = buildExpressionParser table factor <?> "expression"
- where
- table = [
- [unary "-" negate, unary "+" id],
- [op "**" (**) AssocRight],
- [op "*" (*) AssocLeft, op "/" (/) AssocLeft],
- [op "+" (+) AssocLeft, op "-" (-) AssocLeft]
- ]
- op s f assoc = Infix (do{ reservedOp s; return f } <?> "operator") assoc
- unary s f = Prefix (do{ reservedOp s; return f })
-
-factor :: Parser Double
-factor =
- do {
- parens expr;
- } <|> do {
- norf <- naturalOrFloat;
- case norf of
- Left i -> return $ fromInteger i
- Right f -> return $ f
- } <?>
- "factor"
-
-repl :: String -> (String -> Bool) -> (String -> String) -> IO ()
-repl prompt bQuit eval = loop
- where
- loop = do
- putStr prompt
- s <- getLine
- if bQuit s
- then return ()
- else putStrLn (eval s) >> loop
-
-calc :: IO ()
-calc = repl "> " (== ":q") (tostring . parse stmt "")
- where
- tostring (Right v) = show v
- tostring (Left err) = show err
- stmt = do
- e <- expr
- eof
- return e
-
-main = hSetBuffering stdout NoBuffering >> putStrLn "type ':q' to quit." >> calc >> putStrLn "Bye"
+lexer = P.makeTokenParser (haskellDef { reservedOpNames = ["*","/","+","-","<<",">>","^"] })
+
+decimal = P.decimal lexer
+hexadecimal = P.hexadecimal lexer
+parens = P.parens lexer
+reservedOp = P.reservedOp lexer
+
+expr :: [DictElem] -> Parser Word32
+expr d = buildExpressionParser table (factor_spaces d) <?> "expression"
+ where
+ table = [
+ [unary "-" negate, unary "+" id],
+ [op "<<" myShiftL AssocLeft, op ">>" myShiftR AssocLeft],
+ [op "*" (*) AssocLeft, op "/" div AssocLeft],
+ [op "^" xor AssocLeft],
+ [op "+" (+) AssocLeft, op "-" (-) AssocLeft]
+ ]
+ op s f assoc = Infix (do{ reservedOp s; return f } <?> "operator") assoc
+ unary s f = Prefix (do{ reservedOp s; return f })
+
+myShiftL :: Word32 -> Word32 -> Word32
+myShiftL b x = shiftL b (fromInteger $ toInteger x)
+myShiftR :: Word32 -> Word32 -> Word32
+myShiftR b x = shiftR b (fromInteger $ toInteger x)
+
+factor_spaces :: [DictElem] -> Parser Word32
+factor_spaces d = do
+ parseMySpaces
+ r <- factor d
+ parseMySpaces
+ return r
+
+factor :: [DictElem] -> Parser Word32
+factor d =
+ do {
+ parens (expr d);
+ } <|> do {
+ -- define or label
+ s <- foldl1 (<|>) (fmap (try . string . fst) d);
+ return $ (get_elem s d)
+ } <|> try (do {
+ string "0";
+ r <- hexadecimal;
+ return $ fromInteger r
+ } ) <|> do {
+ r <- decimal;
+ return $ fromInteger r
+ } <?> "factor"
+
+testExpr :: String -> IO ()
+testExpr i = case (parse (expr dict) "" i) of
+ Left err -> do {putStr "failz ;(\n"; print err}
+ Right x -> do {printf "erg: 0x%08x\n" x}
+ where
+ dict = [("lolz", 0x1337), ("rofl", 0xaaaa)]