module DT where

import DTFormat

import Prelude hiding (and,or)

import Data.Bits hiding (xor)
import qualified Data.Map as Map
import Data.Word
import Text.Printf
import Text.Parsec
import Text.Parsec.String
import Text.Parsec.Combinator
import Control.Monad
import Control.Applicative hiding ((<|>))


-- parsing --
instruction :: Dict -> Parser Word32
instruction dict = foldl1 (<|>) (fmap (\x -> try (x dict)) instructions) <* char '\n'

testins :: String -> IO ()
testins input =
	case (parse (instruction dict) "" (input++"\n")) of
		Left err -> do { putStr "fail :/\n"; print err}
		Right x -> do { printf "0x%08X\n" x }
	where
	dict = (0x8000,[("lolz", 0x1337), ("rofl", 0xaaaa)])


comma = char ','
mnem m = string m

iLabel :: Dict -> Parser Word32
iLabel (addr,dict) = do
	s <- foldl1 (<|>) (fmap (try . string . fst) dict)
	let lab = get_elem s dict
	return $ ((lab - addr) .&. 0xefff)

iLit :: Parser Word32
iLit = do { parseMySpaces; ret <- liftM read (many1 digit); parseMySpaces; return ret}

-- TODO: ...
iLit12 = iLit
iLit15 = iLit 
iLit16 = iLit 

imm4 :: Parser String
imm4 = do
	try (do a <- digit; b <- digit; return $ [a,b]) <|> (do a <- digit; return $ [a])

read4imm :: String -> Word32
read4imm s = if erg > 15 then error "invalid register" else erg
	where erg = read s

reg :: Parser Word32
reg = do {parseMySpaces; string "r"; ret <- liftM read4imm (imm4); parseMySpaces; return ret}

condition :: Parser Word32
condition = do
	str <- foldl1 (<|>) (fmap (try . string . fst) conds)
	let (Just ret) = lookup str conds
	return $ ret

carry :: Parser Word32
carry = do { char 'c'; return 1} <|> do {string ""; return 0}

updateDisable :: Parser Word32
updateDisable = do { char 'd'; return 1} <|> do {string ""; return 0}

highlow :: Parser Word32
highlow = do { char 'h'; return 1} <|> do {char 'l'; return 0} <|> do {string ""; return 0}

fill :: Parser Word32
fill = do { char 'f'; return 1} <|> do {string ""; return 0}

sign :: Parser Word32
sign = do { char 's'; return 1} <|> do {string ""; return 0}

branchpred :: Parser Word32
branchpred = do
	x <- do { char '+'; return 1} <|> do {char '-'; return 0} <|> do {string ""; return 0}
	parseMySpaces
	return x

shiftArith :: Parser Word32
shiftArith = do { char 'a'; return 1} <|> do {string ""; return 0}

(<.>) p n = p<*comma<*>n
(<%>) p n = p<*space<*>n
(<@>) p n = p<*char '('<*>n<*char ')'
infixl 1 <.>
infixl 1 <%>
infixl 1 <@>

ins m form e  = do {mnem m; form e}
csv0i_p dict f = f<$>condition<*>branchpred<*>(iLabel dict)
csv0i_p' f = f<$>condition<*>branchpred
csv2_scd f = f<$>sign<*>carry<*>updateDisable<*>condition<%>reg<.>reg
csv2m f = f<$>condition<%>reg<.>iLit15<@>reg
csv2i_scd f = f<$>sign<*>carry<*>updateDisable<*>condition<%>reg<.>reg<.>iLit12
csv2i_sl f = f<$>sign<*>highlow<*>condition<%>reg<.>iLit16
csv2i_lfd f = f<$>highlow<*>fill<*>updateDisable<*>condition<%>reg<.>iLit16
csv3_cd f = f<$>carry<*>updateDisable<*>condition<%>reg<.>reg<.>reg
csv3_d f = f<$>updateDisable<*>condition<%>reg<.>reg<.>reg

-- ppc64 stuff (TODO: remove)
v1 f = f<$>iLit
csv4 f = f<$>iLit<.>iLit<.>iLit<.>iLit
csv5 f = f<$>iLit<.>iLit<.>iLit<.>iLit<.>iLit


instructions = [add, addi, mov, sub, subi,
	and, andx,
	--, or, orx, xor, xorx,not]
	-- pop, push, disc, fetch
	-- movpf, movsf, movpt, movst
	-- ldh, ldb
	ldw, ldi,
	-- stw, sth, stb
	-- ldx, stx
	-- call, reti
	br, ret
	-- brr, callr
	-- cmp, cmpi
	]

-- arithmetic
add _ = ins "add" csv3_cd $ aform 0x00
addi _ = ins "addi" csv2i_scd $ aformi 0x02
mov _ = ins "mov" csv2_scd $ aformi' 0x02
sub _ = ins "sub" csv3_cd $ aform 0x01
subi _ = ins "subi" csv2i_scd $ aformi 0x03
-- logic
and _ = ins "and" csv3_d $ aform 0x04 0
andx _ = ins "andx" csv2i_lfd $ lformi 0x05
-- memory
ldw _ = ins "ldw" csv2m $ mformi 0x0e
ldi _ = ins "ldi" csv2i_sl $ lformi' 0x1a
-- misc
-- set signed by default! in very rare cases this can be an issue.
br dict = ins "br" (csv0i_p dict) $ bform 0x16 0x0 1 
ret _ = ins "ret" csv0i_p' $ bform' 0x16 0x2
reti _ = ins "reti" csv0i_p' $ bform' 0x16 0x3

-- instruction formats
aform opcd c d cond rd ra rb = pack [(cond,28),(opcd,23),(rd,19),(ra,15),(rb,11),(free,2),(c,1),(d,0)]
	where free = 0

aformi opcd s c d cond rd ra imm = pack [(cond,28),(opcd,23),(rd,19),(ra,15),(imm,3),(s,2),(c,1),(d,0)]
aformi' opcd s c d cond rd ra = aformi opcd s c d cond rd ra 0

lformi opcd hl f d cond rd imm = pack [(cond,28),(opcd,23),(rd,19),(imm,3),(hl,2),(f,1),(d,0)]
lformi' opcd s hl cond rd imm = lformi opcd s hl 0 cond rd imm

mformi opcd cond rd disp ra = pack [(cond,28),(opcd,23),(rd,19),(ra,15),(disp,0)]

bform opcd typ s cond bp imm = pack [(cond,28),(opcd,23),(imm,7),(free,4),(typ,2),(bp,1),(s,0)]
	where free = 0
bform' opcd typ cond bp = bform opcd typ 0 cond bp 0

-- ppc64 stuff (TODO: remove)
iform opcd aa lk li = pack [(opcd,6),(li,30),(aa,31),(lk,0)]
scform opcd lev = pack [(opcd,6),(lev,27),(1,31)]
dform'b opcd bf l ra si = pack [(opcd,6),(bf,9),(0,10),(l,11),(ra,16),(si,0)]
dsform opcd rt ra ds xo = pack [(opcd,6),(rt,11),(ra,16),(ds,30),(xo,0)]
xform'a opcd rt ra rb xo = pack [(opcd,6),(rt,11),(ra,16),(rb,21),(xo,31)]
xform'b opcd xo bf l ra rb = pack [(opcd,6),(bf,9),(0,10),(l,11),(ra,16),(rb,21),(xo,31),(0,0)]
xform'c opcd xo rs ra rb rc = pack [(opcd,6),(rs,11),(ra,16),(rb,21),(xo,31),(rc,0)]
xform'd opcd xo rc rs ra = pack [(opcd,6),(rs,11),(ra,16),(0,21),(xo,31),(rc,0)]
xlform'a opcd xo bt ba bb = pack [(opcd,6),(bt,11),(ba,16),(bb,21),(xo,31)]
xlform'b opcd xo lk bo bi bh = pack [(opcd,6),(bo,11),(bi,16),(bh,21),(xo,31),(lk,0)]
xlform'c opcd xo bf bfa = pack [(opcd,6),(bf,9),(bfa,14),(xo,31)]
xfxform opcd xo rs spr = pack [(opcd,6),(rs,11),(spr,21),(xo,31)]
xfxform'b opcd h xo fxm rs = pack [(opcd,6),(rs,11),(h,12),(fxm,20),(xo,31)]
--xflform
-- fix xsform
xsform opcd xo rc ra rs sh = pack [(opcd,6),(rs,11),(ra,16),(sh,21),(xo,30),(sh,31),(rc,0)]
xoform' opcd xo oe rc rt ra = pack [(opcd,6),(rt,11),(ra,16),(0,21),(oe,22),(xo,31),(rc,0)]
--aform
mform opcd rc ra rs sh mb me = pack [(opcd,6),(rs,11),(ra,16),(sh,21),(mb,26),(me,31),(rc,0)]
-- mdform needs to be fixed to handle sh correctly
mdform opcd h rc ra rs sh mb = pack [(opcd,6),(rs,11),(ra,16),(sh,21),(mb,27),(h,30),(sh,31),(rc,0)]
mdsform opcd h rc ra rs rb mb = pack [(opcd,6),(rs,11),(ra,16),(rb,21),(mb,27),(h,31),(rc,0)]

-- bit-packing --
pack bf = foldr1 (.|.) $ map (uncurry rotateL) bf

-- condition table
conds :: [(String,Word32)]
conds = [
	("nq", 0x0), ("nz", 0x0),
	("eq", 0x1), ("zs", 0x1),
	("no", 0x2),
	("ov", 0x3),
	("nc", 0x4), ("ae", 0x4),
	("cs", 0x5), ("bl", 0x5),
	("ns", 0x6), ("nn", 0x6),
	("ss", 0x7), ("ns", 0x7),
	("ab", 0x8),
	("be", 0x9),
	("ge", 0xa),
	("lt", 0xb),
	("gt", 0xc),
	("le", 0xd),
	("nv", 0xf),
	("", 0xe) -- always
	]