{-# LANGUAGE RecordWildCards #-}
import Numeric (showHex)
import System.Environment
import Prelude hiding ((*>), (<$), (<*),EQ)
import ParseLib.Abstract
import Debug.Trace

main :: IO()
main = do
  args <- getArgs
  mapM_ handleFile args

handleFile :: String -> IO()
handleFile infile = do
  text <- readFile infile
  let
    program = run tokenToProgram (trace ("Tokens:"++show tokens) tokens)
    tokens  = run scanner text
  print $ foldProgram hexAlgebra (trace ("program:"++show program) program)

run :: Parser s a -> [s] -> a
run p x = fst . head .  parse (p<* eof) $ x


hexAlgebra :: ProgramAlgebra String ([(String,Int)]->String,[String]) String
                             Int Int Int ([(String,Int)]->Int) Int  ([(String,Int)]->Int)
hexAlgebra = ProgramAlgebra hexProg id hexLoad hexAnd hexOr hexXor hexAdd hexSub
                            hexStore hexJmp hexInstrref hexBus hexAddrbus hexRegister
                            hexAddrident hexAddrnum hexCondition hexAddrident
                            hexAddrnum 

pairup :: [a] -> [b] -> [(a,b)]
pairup (x:xs) (y:ys) = (x,y):(pairup xs ys)
pairup [] [] = []


hexProg :: [String] -> [([(String,Int)]->String,[String])] -> String
hexProg vars lines = concatMap hexline lines
  where
    hexline (f, _) = f table
    table = varTable ++ trace ("refTable:" ++(show refTable)) refTable
    varTable = pairup vars [0..(length vars - 1)]
    refTable = fst $ foldl g ([],0) lines
    g ::([(String,Int)],Int) -> ([(String,Int)]->String,[String]) -> ([(String,Int)],Int)
    g  (xs,l) (_,ss)= ((map (\s -> (s,l)) ss)++xs,if ss==[] then l+1 else l)


combineHex :: [(Int,Int)] -> String
showHex' :: Int -> String
showHex' i = showHex i ""
combineHex xs= addZeros $ showHex' (foldl g 0  xs)
  where 
   g :: Int -> (Int,Int) -> Int
   g  s (i,p)= s*2^p+i
   addZeros ss = replicate (amZeros-length ss) '0' ++ ss
   amZeros = ceiling $ (fromIntegral $ sum $ (map (\(_,s)->s) xs)) / 4
loadinstr i i1 i2 i3 addr = (\xs -> combineHex [(i,3), (i1,2), (i2,2), (i3,1),(addr xs,8)],[])
hexLoad = loadinstr 0
hexAnd = loadinstr 1
hexOr  = loadinstr 2
hexXor = loadinstr 3
hexAdd = loadinstr 4
hexSub = loadinstr 5
hexStore i1 i2 addr= (\xs -> combineHex [(6,3), (i1,2), (i2,1), (0,2),(addr xs,8)],[])
hexJmp cond addrbus addr = (\xs -> combineHex [(7,3), (cond,3),(0,1),(addrbus,1),(addr xs,8)],[])
hexInstrref s = (const "", [s])
hexBus BusMem = 0
hexBus BusOp = 1
hexBus BusIn = 2
hexBus BusAcc = 3
hexAddrbus AddrBusOp = 0
hexAddrbus AddrBusAcc = 1
hexRegister RegPP = 0
hexRegister RegMP = 1
hexRegister RegisterAcc = 2
hexRegister RegX = 3
hexAddrident s = \xs -> case lookup s xs of
                              Just i -> i
                              otherwise -> error (s++" does not exist")
                  
hexAddrnum i = const i
hexCondition CondAlw = 0 
hexCondition CondGrt = 1 
hexCondition CondGeq = 2 
hexCondition CondEq = 3 
hexCondition CondLst = 4 
hexCondition CondLeq = 5 
hexCondition CondCry = 6 
hexCondition CondNeq = 7 

data ProgramAlgebra a b c d e f g h i
  = ProgramAlgebra
    { prog     :: [a] -> [b] -> c
    
    , string   :: String -> a
    
    , codeload :: d -> f -> e -> g -> b
    , codeand  :: d -> f -> e -> g -> b
    , codeor   :: d -> f -> e -> g -> b
    , codexor  :: d -> f -> e -> g -> b
    , codeadd  :: d -> f -> e -> g -> b
    , codesub  :: d -> f -> e -> g -> b
    , codestore:: d ->      e -> g -> b
    , codejmp  :: h ->      e -> i -> b
    , codeinstrref:: String ->b
    
    , bus :: Bus -> d
    , addrbus :: AddrBus -> e
    , register :: Register -> f
    , addrident :: String -> g
    , addrnum :: Int -> g
    , condition :: Condition -> h
    , programaddrident :: String -> i
    , programaddrnum :: Int -> i
    }

foldProgram :: ProgramAlgebra a b c d e f g h i -> Program -> c
foldProgram ProgramAlgebra{..} = fProg where
  fProg (Program ss cs)     = prog      (map string ss) (map fCode cs)
  fCode (CodeLoad  b r ab a) = codeload  (bus b) (register r) (addrbus ab) (fAddress a)
  fCode (CodeAnd   b r ab a) = codeand   (bus b) (register r) (addrbus ab) (fAddress a)
  fCode (CodeOr    b r ab a) = codeor    (bus b) (register r) (addrbus ab) (fAddress a)
  fCode (CodeXor   b r ab a) = codexor   (bus b) (register r) (addrbus ab) (fAddress a)
  fCode (CodeAdd   b r ab a) = codeadd   (bus b) (register r) (addrbus ab) (fAddress a)
  fCode (CodeSub   b r ab a) = codesub   (bus b) (register r) (addrbus ab) (fAddress a)
  fCode (CodeStore b ab a)   = codestore (bus b)              (addrbus ab) (fAddress a)
  fCode (CodeJmp h ab i)     = codejmp   (condition h)        (addrbus ab) (fProgAddr i)
  fCode (CodeInstrRef s)     = codeinstrref s

  fAddress (AddrIdent s) = addrident s
  fAddress (AddrNum s)   = addrnum s
  
  fProgAddr (ProgramAddrIdent s) = programaddrident s
  fProgAddr (ProgramAddrNum s) = programaddrnum s



data Program = Program [String] [CodeLine]
  deriving Show
data CodeLine 
  = CodeLoad  Bus Register AddrBus Address
  | CodeAnd   Bus Register AddrBus Address
  | CodeOr    Bus Register AddrBus Address
  | CodeXor   Bus Register AddrBus Address
  | CodeAdd   Bus Register AddrBus Address
  | CodeSub   Bus Register AddrBus Address
  | CodeStore Bus          AddrBus Address
  | CodeJmp   Condition    AddrBus ProgramAddress
  | CodeInstrRef String
  deriving Show

data Bus = BusMem | BusOp | BusIn | BusAcc
  deriving Show
data AddrBus = AddrBusOp | AddrBusAcc
  deriving Show
data Register = RegPP | RegMP | RegisterAcc | RegX
  deriving Show
data Address = AddrIdent String | AddrNum Int
   deriving Show
data Condition = CondAlw | CondGrt | CondGeq | CondEq | CondLst | CondLeq | CondCry | CondNeq
   deriving Show
data ProgramAddress = ProgramAddrIdent String | ProgramAddrNum Int
   deriving Show

tokenToProgram :: Parser Token Program
tokenToProgram = Program <$> many pVariable <*> greedy pCodeLine

pVariable :: Parser Token String
pVariable = (\(Ident s)-> s) <$> satisfy isIdent 
  where
    isIdent (Ident s) = True
    isIdent _ = False

pCodeLine :: Parser Token CodeLine
pCodeLine = symbol (Keyword Load )*>(CodeLoad <$>pBus<*>pRegister<*>pAddrBus<*>pAddress)
         <|>symbol (Keyword And  )*>(CodeAnd  <$>pBus<*>pRegister<*>pAddrBus<*>pAddress)
         <|>symbol (Keyword Xor  )*>(CodeXor  <$>pBus<*>pRegister<*>pAddrBus<*>pAddress)
         <|>symbol (Keyword Add  )*>(CodeAdd  <$>pBus<*>pRegister<*>pAddrBus<*>pAddress)
         <|>symbol (Keyword Sub  )*>(CodeSub  <$>pBus<*>pRegister<*>pAddrBus<*>pAddress)
         <|>symbol (Keyword Store)*>(CodeStore<$>pBus            <*>pAddrBus<*>pAddress)
         <|>symbol (Keyword Jmp  )*>(CodeJmp  <$>pCondition      <*>pAddrBus<*>pProgramAddress)
         <|>CodeInstrRef <$> ( (\(InstrRef s) ->s) <$> satisfy isInstrRef)
  where
    isInstrRef (InstrRef _) = True
    isInstrRef _ = False

pCondition = convert [(Keyword Alw, CondAlw), (Keyword GRT,CondGrt), (Keyword GEQ, CondGeq), (Keyword EQ,CondEq),
  (Keyword LST, CondLst), (Keyword LEQ, CondLeq), (Keyword Cry, CondCry), (Keyword NEQ, CondNeq)]
pBus =  convert [(Keyword Mem,BusMem),(Keyword Op,BusOp), (Keyword In,BusIn), (Keyword Acc,BusAcc)]
pAddrBus = convert [(Keyword Op,AddrBusOp),(Keyword Acc,AddrBusAcc)]
pRegister = convert [(Keyword PP, RegPP), (Keyword MP, RegMP), (Keyword Acc, RegisterAcc), (Keyword X, RegX)]

convert:: (Eq a)=>[(a,b)] -> Parser a b
convert xs = foldr (<|>) empty (map convertSingle xs)
  where
    convertSingle::(Eq a)=> (a,b) -> Parser a b
    convertSingle (a,b) = const b <$> symbol a


pAddress :: Parser Token Address
pAddress = (\(Ident s) -> AddrIdent s) <$> satisfy isIdent
               <|>(\(Num n) -> AddrNum n) <$> satisfy isNum
  where
    isNum (Num _) = True
    isNum _ = False
    isIdent (Ident s) = True
    isIdent _ = False

pProgramAddress :: Parser Token ProgramAddress
pProgramAddress = (\(Ident s) -> ProgramAddrIdent s) <$> satisfy isIdent
               <|>(\(Num n) -> ProgramAddrNum n) <$> satisfy isNum
  where
    isNum (Num _) = True
    isNum _ = False
    isIdent (Ident _) = True
    isIdent _ = False

scanner :: Parser  Char [Token]
scanner = whiteSpace *>  greedy ( ptoken <* whiteSpace) <* eof

ptoken :: Parser Char Token
ptoken = foldr (<<|>) empty 
  [ Keyword <$> choice (map (\a -> a <$ token (show a)) [minBound..maxBound]),
    Num <$> pDecimal,
    Num <$> pHex,
    InstrRef <$> pIdent <* token ":",
    Ident <$> pIdent]


pIdent :: Parser Char String
pIdent =  (:) <$> satisfy isAlpha <*>  greedy (satisfy isAlphaNum)

pDecimal :: Parser Char Int
pDecimal = read <$> greedy1 (satisfy isDigit)

pHex :: Parser Char Int
pHex = (\c c' s -> read (c:c':s)) <$> (symbol '0') <*> 
       satisfy (\c -> elem c ['x','X']) <*> 
       greedy1 (satisfy isDigit)

isDigit :: Char -> Bool
isDigit c = c>='0' && c<='9'


isAlpha :: Char -> Bool
isAlpha c = (c>='a' && c<='z') || (c>='A' && c<='Z')

isAlphaNum :: Char -> Bool
isAlphaNum c = isAlpha c || isDigit c


whiteSpace :: Parser Char String
whiteSpace = greedy (satisfy isSpace <|> comment)

isSpace :: Char -> Bool
isSpace c = elem c [' ', '\t', '\n']

comment :: Parser Char Char
comment = (\_ _ -> 'c')<$> token "//" <*>  greedy (satisfy (/='\n'))


data Token 
  = Ident String
  | Num Int
  | InstrRef String
  | Keyword Keyword
  deriving (Show,Eq)
  

data Keyword
  = Load | And | Or | Xor | Add | Sub | Store | Jmp
  | Mem | Op | In | Acc
  | PP | MP | X
  | Alw | GRT | GEQ | EQ | LST | LEQ | Cry | NEQ
  deriving (Show, Bounded, Enum,Eq)