{-# OPTIONS -fglasgow-exts #-}

module ObjectFileParser {-(readObjectFile, showObjectFile)-} where

import Char
import Control.Arrow
import Control.Monad
import Control.Monad.Instances
import Control.Monad.State
import Data.List
import Data.Maybe
import qualified Data.Map as M
import Data.Word
import Debug.Trace
import Numeric
import Text.ParserCombinators.Parsec
import System.IO.Error

import ObjectFile

readDec' s =
	case readDec s of
		[(n,_)] -> Just n
		_ -> Nothing

splitAtM n xs
	| length xs >= n = return (splitAt n xs)
	| otherwise = fail "splitAtM failed"

--readHex' :: (Monad m, Num a) => String -> m a
readHex' s =
	case readHex s of
		[(n,_)] -> return n
		_ -> fail "No parse in readHex'"
	
sortOn f = sortBy (\x y -> compare x y)

{-

the basic object file format is:

file:
LINK
nsegs nsyms nrels
-- segments --
-- symbols --
-- rels --
-- data --

segment:
(numbers base-16!)
name base size flags

symbol:
name value seg type

relocation:
loc seg ref type

-}

parseSection :: String -> Maybe Section
parseSection s = parse (words s)
	where
	parse [name,base,size,flags] = do
		base' <- readHex' base
		size' <- readHex' size
		return (Section name base' size' (readSectionFlags flags) M.empty [] [])
	parse _ = Nothing

printSection s =
	unwords
		[secName s
		,showHex (secBase s) ""
		,showHex (secSize s) ""
		,showSectionFlags (secFlags s)]

parseSymbol :: String -> Maybe Symbol
parseSymbol s = parse (words s)
	where
	parse [name,value,seg,tp] = do
		val' <- readHex' value
		seg' <- readDec' seg
		let ret = (Symbol name val' seg' tp)
		return (trace ("Parse sym \""++s++"\" yields "++show ret) ret)
	parse _ = trace ("Parse sym failed: "++s) Nothing

printSymbol s =
	unwords
		[symName s
		,showHex (symValue s) ""
		,showHex (symSection s) ""
		,symType s]

parseRelocation :: String -> Maybe Relocation
parseRelocation s = parse (words s)
	where
	parse [loc,seg,ref,tp] = do
		loc' <- readHex' loc
		seg' <- readDec' seg
		ref' <- readDec' ref
		tp' <- read tp
		return (Relocation loc' seg' ref' tp')
	parse _ = Nothing

printRelocation r =
	unwords
		[showHex (relLocation r) ""
		,showInt (relSection r) ""
		,showInt (relRef r) ""
		,show (relType r)]

parseN :: (Monad m) => Int -> (String -> m b) -> [String] -> m ([b],[String])
parseN n parser xs = do
	(xs,tail) <- splitAtM n xs
	xs <- mapM parser xs
	return (xs,tail)

takeItem :: ({-Monad m,-} MonadState [a] m) => m a
takeItem = do
	(x:xs) <- get
	put xs
	return x

parseSymbols 0 sections = return sections
parseSymbols n sections = do
	Just sym <- liftM parseSymbol takeItem
	parseSymbols (n-1) $
		M.update (Just . trace ("Parsed sym: "++show sym). addSymbol sym) (symSection sym) sections

parseSections 0 _ sections = return sections
parseSections n i sections = do
	Just sec <- fmap parseSection takeItem
	parseSections (n-1) (i+1) (M.insert i sec sections)

parseHex xs = Just []

parseBinaries 0 _ sections = return sections
parseBinaries n i sections =
	(if hasFlag Present . secFlags . fromJust . M.lookup i $ sections
			then fmap parseHex takeItem >>= (\(Just image) ->
				return (M.update (addBinaryData image) i sections))
			else return sections) >>=
	parseBinaries (n-1) (i+1)
	where
		addBinaryData image sec = Just (sec { secData = image })

splitAts [] list = [list]
splitAts (x:xs) list = y : splitAts xs tail
	where (y,tail) = splitAt x list

addRelocM rel = modify $ M.update (Just . addReloc rel) (relSection rel)
addSymbolM sym = modify $ M.update (Just . addSymbol sym) (symSection sym)

readObjectFile str = do
		let (magic:header:tail) = lines str
		matchMagic magic
		[nsegs,nsyms,nrels] <- sequence . map readDec' . words $ header
		
		let [segs,syms,rels,tail'] = splitAts [nsegs,nsyms,nrels] tail
		
		segments <- fmap (M.fromList . zip [1..]) $ mapM parseSection segs
		symbols <- mapM parseSymbol syms
		relocations <- mapM parseRelocation rels
		let (_,sections) = runState (do
				mapM_ addSymbolM symbols
				mapM_ addRelocM relocations) segments
		
		return (ObjectFile sections)
	where
		matchMagic "LINK" = Just ()
		matchMagic _ = Nothing

showObjectFile o = unlines $
	["LINK"] ++
	[unwords . map show $ [numSections, numSymbols, numRelocs]] ++
	map printSection allSections ++
	map printSymbol allSymbols ++
	map printRelocation allRelocs
	
	where
		allSections = map snd $ M.toList (sections o)
		allSymbols = concatMap (map snd . M.toList . secSymbols) allSections
		allRelocs = concatMap secRelocs allSections
		numSections = M.size (sections o)
		numSymbols = sum (map (M.size . secSymbols) allSections)
		numRelocs = sum (map (length . secRelocs) allSections)