module DT where

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 ((<|>))

parseInstructions = many1 instruction

testins :: String -> IO ()
testins input =
	case (parse instruction "" (input++"\n")) of
		Left err -> do { putStr "fail :/"; print err}
		Right x -> do { printf "0x%08X\n" x }

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

instructions = [add]

comma = char ','
mnem m = string m

iLit :: Parser Word32
iLit = liftM read (many1 digit)

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 {string "r"; liftM read4imm (imm4)}

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

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

{-
addi = ins "addi" csv3 $ aform 
dform'a opcd rt ra d = pack [(opcd,6),(rt,11),(ra,16),(d,0)]
-}

add = ins "add" csv3 $ aform 0 0 0


---
ins m form e  = mnem m>>form e
v1 f = f<$>iLit
csv2 f =f<$>iLit<.>iLit
csv3 f = f<$>condition<%>reg<.>reg<.>reg
csv4 f = f<$>iLit<.>iLit<.>iLit<.>iLit
csv5 f = f<$>iLit<.>iLit<.>iLit<.>iLit<.>iLit

-- instruction formats
aform :: Word32 -> Word32 -> Word32 -> Word32 -> Word32 -> Word32 -> Word32 -> Word32
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

-- ppc64 stuff
iform opcd aa lk li = pack [(opcd,6),(li,30),(aa,31),(lk,0)]
bform opcd aa lk bo bi bd = pack [(opcd,6),(bo,11),(bi,16),(bd,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
	]