{-   `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/>. -}

import DT hiding (not)
import DTFormat
import Expr_eval

import Control.Applicative hiding ((<|>),many)

import System.IO
import System.Environment
import Text.Printf
import Text.Parsec
import Text.Parsec.String
import Text.Parsec.Combinator
import qualified Data.Map as M
import Data.List
import Data.Char
import Data.Word
import Data.Bits
import qualified Data.ByteString.Lazy as BL
import Control.Monad


main :: IO ()
main = do
	args <- getArgs
	content <- getContents
	let src = (filter (((/=) "") . snd) $ (zip [1..] (lines content)))
	let (dict,formatedsrc) = convertDTF src NoState 0x00 0x00 [("start_",0x00)]
	if (not $ null args) && ("-d" `elem` args)
		then do
			printf "\nlabels:\n"
			sequence_ [printf "%20s @ 0x%08x\n" l a | (l,a) <- (reverse dict)]
			printf "\nparsed asm:\n"
			sequence_ [printf "%s" (show x) | x <- formatedsrc]
			printf "\nafter parsing the instructions:\n"
		else do
			printf ""
	let base = if "-b" `elem` args then 2 else 16
	let parsed = parseInstr (reverse $ sort dict) formatedsrc
	sequence_ [printf "%s" (showsDTFBase x base "") | x <- parsed]


parseInstr :: [DictElem] -> [DTF] -> [DTF]
parseInstr _ [] = []
parseInstr dict ((DTF_InstrToParse a instr c l s lno):xs) =
	(DTF_Instr a bytecode c l s):(parseInstr dict xs)
	where
	bytecode = case (parse (instruction lno (a,dict)) "" (instr++"\n")) of
		Left err -> error ("couldn't parse Instruction: " ++ instr ++ "\n" ++ show err)
		Right x -> x
parseInstr dict (x:xs) = x:(parseInstr dict xs)


type Counter = Word32

inc :: Counter -> Counter
inc = ((+) 4)


convertDTF :: [(LineNo,String)] -> DT_State -> Counter -> Counter -> [DictElem] -> ([DictElem], [DTF])
convertDTF [] _ _ _ d = (d,[])
convertDTF ((lno,str):xs) state datacnt instrcnt dict = (newdict, (actlist newdtf))
	where
	actlist (DTF_Org _) = next
	actlist (DTF_State _) = next
	actlist (DTF_Define _ _ _) = next
	actlist (DTF_Fill rep val code l c) = if state == InData then
		(DTF_Data datacnt val code l c):[(DTF_Data dc val "" "" "") | i<-[2..repi], let dc = [(datacnt+0x4),(datacnt+0x8)..]!!(i-2)] ++ next
		else
		(DTF_Instr instrcnt val code l c):[(DTF_Instr ic val "" "" "") | i<-[2..repi], let ic = [(instrcnt+0x4),(instrcnt+0x8)..]!!(i-2)] ++ next
		where
		repi :: Int
		repi = fromInteger (toInteger rep)
	actlist (DTF_Ascii str lab code comment) =
		(DTF_Data datacnt (strval!!0) code lab comment):
		[(DTF_Data ic (strval!!i) code lab comment)
		| i<-[1..len]
		, let ic = [datacnt,(datacnt+0x4)..]!!i
		]
		++ next
		where
		len = ((length str)`div`4)
		strval :: [Word32]
		strval = pf $ map (\x -> fromIntegral $ ord x :: Word8) str
		pf :: [Word8] -> [Word32]
		pf [] = []
		pf xs@(_:[]) = pf (xs ++ [0,0,0])
		pf xs@(_:_:[]) = pf (xs ++ [0,0])
		pf xs@(_:_:_:[]) = pf (xs ++ [0])
		pf (a:b:c:d:xs) = (foldl' accum 0 [d,c,b,a]):(pf xs)
			where
			accum x o = (x `shiftL` 8) .|. fromIntegral o
	actlist y = y:next

	(newdict,next) = convertDTF xs (nstate newdtf) (ndatacnt newdtf) (ninstrcnt newdtf) (ndict newdtf)

	ndatacnt (DTF_Org adr)
		| state == InData = adr
		| otherwise = datacnt
	ndatacnt (DTF_Fill rep _ _ _ _)
		| state == InData = datacnt + (4*rep)
		| otherwise = datacnt
	ndatacnt (DTF_Ascii str _ _ _)
		| state == InData = datacnt + (4*len)
		where len = fromIntegral $ ((length str)`div`4)+1
	ndatacnt (DTF_Data _ _ _ _ _) = inc datacnt
	ndatacnt _ = datacnt

	ninstrcnt (DTF_Org adr)
		| state == InText = adr
		| otherwise = instrcnt
	ninstrcnt (DTF_Fill rep _ _ _ _)
		| state == InText = instrcnt + (4*rep)
		| otherwise = instrcnt
	ninstrcnt (DTF_Instr _ _ _ _ _) = inc instrcnt
	ninstrcnt (DTF_InstrToParse _ _ _ _ _ _) = inc instrcnt
	ninstrcnt _ = instrcnt

	nstate (DTF_State s) = s
	nstate _ = state

	ndict (DTF_Label l _ a) = dict `add_elem` (l,a)
	ndict (DTF_SectionToDet a _ _ l _) = dict `add_elem` (l,a)
	ndict (DTF_InstrToParse a _ _ l _ _) = dict `add_elem` (l,a)
	ndict (DTF_Data a _ _ l _) = dict `add_elem` (l,a)
	ndict (DTF_Instr a _ _ l _) = dict `add_elem` (l,a)
	ndict (DTF_Define l v _) = dict `add_elem` (l,v)
	ndict (DTF_Fill _ _ _ l _)
		| state == InText = dict `add_elem` (l,instrcnt)
		| state == InData = dict `add_elem` (l,datacnt)
	ndict (DTF_Ascii _ l c _)
		| state == InData = dict `add_elem` (l,datacnt)
		| otherwise = error $ "don't use .ascii in .text here: " ++ c
	ndict _ = dict

	newdtf = case (parse (parseDTFLine lno dict) "" (str++"\n")) of
		Left err -> error ("couldn't parse line " ++ (show lno) ++ ": " ++ (show err))
		Right (DTF_SectionToDet _ v c l s) ->
			case state of
				NoState -> error "missing .data or .text"
				InData -> (DTF_Data datacnt v c l s)
				InText -> (DTF_Instr instrcnt v c l s)
		Right (DTF_InstrToParse _ v c l s ln) ->
			(DTF_InstrToParse instrcnt v c l s ln)
		Right y@(DTF_Org _) ->
			case state of
				NoState -> error "missing .data or .text"
				_ -> y
		Right (DTF_Label l c _) ->
			case state of
				NoState -> error "missing .data or .text"
				InData -> (DTF_Label l c datacnt)
				InText -> (DTF_Label l c instrcnt)
		Right z -> z -- DTF_Comment, DTF_State, DTF_Define, DTF_Fill, DTF_Ascii

testDTF :: String -> IO ()
testDTF input =
	case (parse (parseDTFLine 0 dict) "" (input++"\n")) of
		Left err -> do { putStr "failz ;(\n"; print err}
		Right x -> do { print x }
	where
	dict = [("lolz", 0x1337), ("rofl", 0xaaaa)]

parseDTFLine :: LineNo -> [DictElem] -> Parser DTF
parseDTFLine lno dict = foldl1 (<|>) (fmap (\x -> try (x lno dict)) lineFormats) <* char '\n'

lineFormats = [lf_define, lf_sdata, lf_stext, lf_org, lf_data, lf_ifill, lf_ascii, lf_comment, lf_toparse, lf_label, lf_nothing]

-- helper
parseIdent :: Parser String
parseIdent = do
	ident <- letter
	idents <- many $ (letter <|> digit <|> char '_')
	return $ (ident:idents)

parseLabel :: Parser String
parseLabel = do
	l <- parseIdent
	char ':'
	return $ l

parseComment :: Parser String
parseComment = do
	skipMany space
	char ';'
	comment <- many $ noneOf "\n"
	return $ comment

parseConst :: [DictElem] -> Parser Word32
parseConst d = expr d

-- teh pars0rs
lf_data _ d = do
	l <- try (parseLabel) <|> string ""
	skipMany space
	fill <- string ".fill "
	repeat <- try (do {size <- many1 $ noneOf "\n;,"; char ','; return $ size}) <|> return "1"
	-- TODO: atm 32bit imm only
	code <- many1 $ noneOf "\n;"
	let val = case parse (parseConst d) "" code of
		Right v -> v
		Left err -> error $ show err
	let r = case parse (parseConst d) "" repeat of
		Right v -> v
		Left err -> error $ show err
	comment <- try(parseComment) <|> parseMySpaces
	return $ DTF_Fill r val (fill ++ (if repeat == "1" then "" else repeat) ++ code) l comment

lf_ifill lno d = do
	l <- try (parseLabel) <|> string ""
	skipMany space
	fill <- string ".ifill "
	code <- many1 $ noneOf "\n;"
	let val = case parse (instruction lno (0,d)) "" (code++"\n") of
		Right v -> v
		Left err -> error $ show err
	comment <- try(parseComment) <|> parseMySpaces
	return $ DTF_Fill 1 val (fill ++ code) l comment

lf_ascii _ _ = do
	l <- try (parseLabel) <|> string ""
	skipMany space
	ascii <- string ".ascii "
	char '"'
	str <- many1 $ noneOf "\"";
	char '"'
	comment <- try(parseComment) <|> parseMySpaces
	return $ DTF_Ascii str (ascii ++ "\"" ++ str ++ "\"") l comment

lf_comment _ _ = do
	comment <- parseComment
	return $ DTF_Comment comment

lf_nothing _ _ = do
	wtf <- parseMySpaces
	return $ DTF_Comment wtf

lf_label _ _ = do
	l <- parseLabel
	comment <- try(parseComment) <|> parseMySpaces
	return $ DTF_Label l comment 0

lf_toparse lno _ = do
	l <- try(parseLabel) <|> string ""
	skipMany space
	code <- many1 $ noneOf "\n;"
	comment <- try(parseComment) <|> parseMySpaces
	return $ DTF_InstrToParse 0 code code l comment lno

lf_org _ d = do
	skipMany space
	string ".org"
	val <- parseConst d
	parseMySpaces
	return $ DTF_Org val

lf_sdata _ _ = do
	skipMany space
	string ".data"
	parseMySpaces
	return $ DTF_State InData

lf_stext _ _ = do
	skipMany space
	string ".text"
	parseMySpaces
	return $ DTF_State InText

lf_define _ d = do
	skipMany space
	string ".define"
	parseMySpaces
	id <- parseIdent
	char ','
	-- TODO: expressions with (expr) do not work ;(
	ret <- parseConst d
	comment <- try(parseComment) <|> parseMySpaces
	return $ DTF_Define id ret comment