{-   `Deep Thought', a softcore CPU implemented on a FPGA

    Copyright (C) 2010 Markus Hofstaetter <markus.manrow@gmx.at>
    Copyright (C) 2010 Martin Perner <e0725782@student.tuwien.ac.at>
    Copyright (C) 2010 Stefan Rebernig <stefan.rebernig@gmail.com>
    Copyright (C) 2010 Manfred Schwarz <e0725898@student.tuwien.ac.at>
    Copyright (C) 2010 Bernhard Urban <lewurm@gmail.com>

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>. -}

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.List
import Data.Bits

lexer :: P.TokenParser ()
lexer = P.makeTokenParser (haskellDef { reservedOpNames = ["*","/","+","-","<<",">>","^"] })

decimal = P.decimal lexer
hexadecimal = P.hexadecimal 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 {
		char '('; r <- expr d; char ')';
		return r
	} <|> 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)]