-- This file is part of Bindings-bfd.
--
-- Copyright (C) 2010 Michael Nelson
--
-- Bindings-bfd is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Lesser General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- Bindings-bfd 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 Lesser General Public License for more details.

-- You should have received a copy of the GNU Lesser General Public License
-- along with Bindings-bfd.  If not, see <http://www.gnu.org/licenses/>.

module Bindings.Bfd (
   -- * Types
     Bfd
   , Bfd'
   , FileMode
   -- * Functions
   -- ** Initialization
   , init
   -- ** Files
   , getTargetsAndFormats
   , open
   , close
   -- ** Format
   , checkFormat
   -- ** Foo
   , Bindings.Bfd.getByteorder
   , Bindings.Bfd.getHeaderByteorder
   , getDisasm
   , getFilename
   , Bindings.Bfd.getFlags
   , Bindings.Bfd.getObjectFlags
   , Bindings.Bfd.getSectionFlags
   , Bindings.Bfd.getFlavour
   , getFormat
   , getMachine
   , getOctetsPerByte
   -- *** Sections
   , getSectionByName
   , getSections
   -- *** Target
   , getTarget
   -- *** Foo
   , getMyArchive
   -- *** Symbols
   , getSymbolTable
   , getDynamicSymbolTable
#if 0
   , getSyntheticSymbolTable
#endif
   -- *** Relocations
   , getDynamicRelocations
   -- ** Testing
   , isBigEndian
   , isLittleEndian
   , isHeaderBigEndian
   , isHeaderLittleEndian
   , isCoffFamily
) where

import Control.Exception
import Control.Monad

import Data.Bits
import Data.Maybe
import Data.Word

import Foreign.C
import Foreign.Marshal
import Foreign.Ptr
import Foreign.Storable

import Prelude hiding (catch, init)

import Bindings.Bfd.Disasm
import Bindings.Bfd.Endian
import Bindings.Bfd.Exception
import Bindings.Bfd.Flags         as BfdFlags
import Bindings.Bfd.Flavour
import Bindings.Bfd.Format
import Bindings.Bfd.Relocation
import Bindings.Bfd.Section       as Section
import Bindings.Bfd.Section.Flags as SectionFlags
import Bindings.Bfd.SymbolTable   as SymbolTable
import Bindings.Bfd.Target        as Target

#include <bfd.h>


type FileMode = String


type Bfd = Ptr Bfd'

data Bfd' = Filename  String
          | XVec      Target
          | Format    Format
          | Flags     Int
          | Sections  Section
          | MyArchive Bfd
     deriving (Show)

instance Storable Bfd' where
   sizeOf _ = #size struct bfd
   alignment = sizeOf
   peekByteOff buf off
      | off == (#offset struct bfd, filename) =
         do
            val <- (#peek struct bfd, filename) buf :: IO CString
            str <- peekCString val
            return $ Filename str
      | off == (#offset struct bfd, xvec) = 
         do
            val <- (#peek struct bfd, xvec) buf :: IO Word
            return $ XVec $ wordPtrToPtr $ fromIntegral val
      | off == (#offset struct bfd, format) =
         do
            val <- (#peek struct bfd, format) buf :: IO CUInt
            return $ Format $ toEnum $ fromIntegral val
      | off == (#offset struct bfd, flags) =
         do
            val <- (#peek struct bfd, flags) buf :: IO CUInt
            return $ Bindings.Bfd.Flags $ fromIntegral val
      | off == (#offset struct bfd, sections) =
         do
            val <- (#peek struct bfd, sections) buf
            return $ Sections val
      | off == (#offset struct bfd, my_archive) =
         do
            val <- (#peek struct bfd, my_archive) buf :: IO Bfd
            return $ MyArchive val
      | otherwise = error $ "internal error: Bfd.peekByteOff " ++ show off
   poke _ _ = return ()


init
   :: IO ()
-- ^ Initialize the library.  Call 'init' before making any other calls.
init = c_bfd_init


getTargetsAndFormats 
   :: FilePath                   -- ^ The file to query
   -> IO [(TargetName, Format)]
-- ^ Returns a 'List' of tuples representing the possible combinations of 
-- 'TargetName' and 'Format' valid for this 'FilePath'.
--
-- Possible Exceptions:  Same as 'open'.
getTargetsAndFormats file =
   do
      ts <- Target.list
      let
         perms = [ (t,f) | t <- ts, f <- enumFrom Object ]
      foldM g [] perms
   where
      g xs r@(t,f) =
         do
            bfd   <- open file (Just t) "r"
            xvec1 <- getTarget bfd
            tn1   <- Target.getName xvec1
            ok    <- catch (checkFormat bfd f) ((\_ -> return False) :: BfdException -> IO Bool)
            case ok of
               True  -> 
                  do
                     xvec2 <- getTarget bfd
                     tn2   <- Target.getName xvec2
                     if tn1 == tn2 
                         then return $ r : xs
                         else return xs
               False -> return xs

open
   :: FilePath          -- ^ File to open
   -> Maybe TargetName  -- ^ Target
   -> FileMode
   -> IO Bfd
-- ^ Opens a file with the given target and mode
-- and returns a bfd object on success.  If the target is 'Nothing' then
-- the file is opened with the default target.
--
-- Possible exceptions:  'NoMemory' (if any allocation fails), 'SystemCall' 
-- (if open failed), and 'InvalidTarget' (if supplied target is not supported).
--
-- /Note:/ 'open' does not validate that the supplied 'TargetName' is appropriate
-- for the supplied file.
open fp targ mode =
   do
      fp'   <- newCString fp
      targ' <- newCString targ0
      mode' <- newCString mode
      throwExceptionIfNull "open" fp targ0 (c_bfd_fopen fp' targ' mode' (-1))
   where
      targ0 = fromMaybe "default" targ

close
   :: Bfd
   -> IO Bool
close bfd = 
   do
      r <- c_bfd_close bfd
      return $ toBool r


checkFormat
   :: Bfd
   -> Format
   -> IO Bool
checkFormat bfd format =
   do
      res <- c_bfd_check_format bfd format'
      throwExceptionIfFalse "checkFormat" (show format) (return $ toBool res)
   where
      format' = fromIntegral $ fromEnum format


getByteorder
   :: Bfd
   -> IO Endian
getByteorder bfd =
   do
      xvec <- getTarget bfd
      Target.getByteorder xvec

getHeaderByteorder
   :: Bfd
   -> IO Endian
getHeaderByteorder bfd =
   do
      xvec <- getTarget bfd
      Target.getHeaderByteorder xvec

getDisasm
   :: Bfd
   -> IO Disasm
getDisasm = c_disassembler
     
getFilename
   :: Bfd
   -> IO String
getFilename bfd =
   do
      fn <- peekByteOff bfd (#offset struct bfd, filename)
      return $ unBfd'Filename fn
 
getFlags
   :: Bfd
   -> IO [BfdFlags.Flags]
getFlags bfd =
   do
      flags <- peekByteOff bfd (#offset struct bfd, flags)
      let
         flags' = filter f $ enumFrom HasReloc
            where
               f e = unBfd'Flags flags .&. (bit $ fromEnum e) /= 0
      return flags'

getObjectFlags
   :: Bfd
   -> IO [BfdFlags.Flags]
getObjectFlags bfd =
   do
      xvec <- getTarget bfd
      Target.getObjectFlags xvec

getSectionFlags
   :: Bfd
   -> IO [SectionFlags.Flags]
getSectionFlags bfd =
   do
      xvec <- getTarget bfd
      Target.getSectionFlags xvec

getFlavour
   :: Bfd
   -> IO Flavour
getFlavour bfd =
   do
      xvec <- getTarget bfd
      Target.getFlavour xvec

getFormat
   :: Bfd
   -> IO Format
getFormat bfd =
   do
      format <- peekByteOff bfd (#offset struct bfd, format)
      return $ unBfd'Format format

getMachine
   :: Bfd
   -> IO Int
getMachine bfd = 
   do
      m <- c_bfd_get_mach bfd
      return $ fromIntegral m

getOctetsPerByte
   :: Bfd
   -> IO Int
getOctetsPerByte bfd =
   do
      opb <- c_bfd_octets_per_byte bfd
      return $ fromIntegral opb

getSectionByName
   :: Bfd
   -> SectionName
   -> IO Section
getSectionByName bfd sn = withCString sn (\s -> c_bfd_get_section_by_name bfd s) 

getSections
   :: Bfd
   -> IO [Section]
getSections bfd =
   do
      (Sections first) <- peekByteOff bfd (#offset struct bfd, sections)
      getSections' first []
   where
      getSections' sect rs
         | sect == nullPtr = return $ reverse rs
         | otherwise       =
              do
                 next <- getNext sect
                 getSections' next (sect : rs)

getTarget
   :: Bfd
   -> IO Target
getTarget bfd = 
   do
      xv <- peekByteOff bfd (#offset struct bfd, xvec)
      return $ unBfd'XVec xv

getMyArchive
   :: Bfd
   -> IO (Maybe Bfd)
getMyArchive bfd =
   do
      ma <- peekByteOff bfd (#offset struct bfd, my_archive)
      return $ case unBfd'MyArchive ma == nullPtr of
         True  -> Nothing
         False -> Just $ unBfd'MyArchive ma

getSymbolTable
   :: Bfd
   -> IO SymbolTable
getSymbolTable bfd =
   do
      xvec  <- getTarget bfd
      bound <- getSymtabUpperBound xvec bfd
      let
         ptrs = bound `quot` (#const sizeof(struct bfd_symbol *))
      pps <- mallocArray ptrs
      count <- canonicalizeSymtab xvec bfd pps
      return $ SymbolTable.mk pps count

getDynamicSymbolTable
   :: Bfd
   -> IO SymbolTable
getDynamicSymbolTable bfd =
   do
      xvec  <- getTarget bfd
      bound <- getDynamicSymtabUpperBound xvec bfd
      let
         ptrs = fromIntegral bound `quot` (#const sizeof(struct bfd_symbol *))
      pps <- mallocArray ptrs
      count <- canonicalizeDynamicSymtab xvec bfd pps
      return $ SymbolTable.mk pps count

#if 0
getSyntheticSymbolTable
   :: Bfd
   -> SymbolTable    -- static
   -> SymbolTable    -- dynamic
   -> IO SymbolTable
getSyntheticSymbolTable bfd sst dst =
   do
      xvec  <- getTarget bfd
      ssyms <- malloc
      count <- getSyntheticSymtab xvec bfd sst dst ssyms
      return $ SymbolTable.mk ssyms count
#endif

getDynamicRelocations
   :: Bfd
   -> SymbolTable
   -> IO [Relocation]
getDynamicRelocations bfd st =
   do
      xvec  <- getTarget bfd
      bound <- getDynamicRelocUpperBound xvec bfd
      let
         ptrs = fromIntegral bound `quot` (#const sizeof(arelent *))
      ppr <- mallocArray ptrs
      count <- canonicalizeDynamicReloc xvec bfd ppr $ tablePtr st
      prs <- peekArray count ppr
      mapM peek prs


isBigEndian
   :: Bfd
   -> IO Bool
isBigEndian bfd =
   do
      bo <- Bindings.Bfd.getByteorder bfd
      return $ bo == Big

isLittleEndian
   :: Bfd
   -> IO Bool
isLittleEndian bfd =
   do
      bo <- Bindings.Bfd.getByteorder bfd
      return $ bo == Little

isHeaderBigEndian
   :: Bfd
   -> IO Bool
isHeaderBigEndian bfd =
   do
      bo <- Bindings.Bfd.getHeaderByteorder bfd
      return $ bo == Big

isHeaderLittleEndian
   :: Bfd
   -> IO Bool
isHeaderLittleEndian bfd =
   do
      bo <- Bindings.Bfd.getHeaderByteorder bfd
      return $ bo == Little

isCoffFamily
   :: Bfd
   -> IO Bool
isCoffFamily bfd =
   do
      flav <- Bindings.Bfd.getFlavour bfd
      return $ flav == Coff || flav == Xcoff

unBfd'Filename
   :: Bfd'
   -> String
unBfd'Filename (Filename fn) = fn
unBfd'Filename _             = error "unBfd'Filename"

unBfd'XVec
   :: Bfd'
   -> Target
unBfd'XVec (XVec p) = p
unBfd'XVec _        = error "unBfd'XVec"

unBfd'Format
   :: Bfd'
   -> Format
unBfd'Format (Format f) = f
unBfd'Format _          = error "unBfd'Format"

unBfd'Flags
   :: Bfd'
   -> Int
unBfd'Flags (Bindings.Bfd.Flags m) = m
unBfd'Flags _                      = error "unBfd'Flags"

unBfd'MyArchive
   :: Bfd'
   -> Bfd
unBfd'MyArchive (MyArchive ma) = ma
unBfd'MyArchive _              = error "unBfd'MyArchive"

#if 0
createSections
   :: Bfd
   -> IO [(Section, Vma)]
createSections bfd = 
   do
      sects         <- getSections bfd
      extSect       <- Section.mk "externs" 5
      (_, sectList) <- foldM f (0,[]) $ sects ++ [extSect]
      return $ reverse sectList
   where
      f (vma,xs') sect =
         do
            (vma',snvma) <- createSection sect vma
            return (vma', snvma : xs')

demangle
   :: Bfd
   -> String
   -> IO String
demangle bfd str =
   do
      s <- withCString str (\s -> c_bfd_demangle bfd s 3)
      case s == nullPtr of
         True  -> return ""
         False ->
            do
               s' <- peekCString s
               return s'
#endif

foreign import ccall unsafe "bfd.h bfd_init" c_bfd_init
   :: IO ()

foreign import ccall unsafe "bfd.h bfd_fopen" c_bfd_fopen
   :: CString
   -> CString
   -> CString
   -> CInt
   -> IO Bfd

foreign import ccall unsafe "bfd.h bfd_close" c_bfd_close
   :: Bfd
   -> IO CInt

foreign import ccall unsafe "bfd.h bfd_check_format" c_bfd_check_format
   :: Bfd
   -> CInt
   -> IO CInt

foreign import ccall unsafe "bfd.h bfd_get_mach" c_bfd_get_mach
   :: Bfd
   -> IO CInt

foreign import ccall unsafe "bfd.h bfd_octets_per_byte" c_bfd_octets_per_byte
   :: Bfd
   -> IO CUInt

foreign import ccall unsafe "bfd.h bfd_get_section_by_name" c_bfd_get_section_by_name
   :: Bfd
   -> CString
   -> IO Section

#if 0
foreign import ccall unsafe "bfd.h bfd_demangle" c_bfd_demangle
   :: Bfd
   -> CString
   -> CInt
   -> IO CString
#endif

foreign import ccall unsafe "dis-asm.h disassembler" c_disassembler
   :: Bfd
   -> IO Disasm