-- This file is part of Bindings-bfd.
--
-- Copyright (C) 2010,2011 Mick Nelso
--
-- 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/>.

-- | The "Target" represents a particular back-end used to interpret the "Bfd".
module Bindings.Bfd.Target (
   -- * Types
     Target
   , TargetName
   -- * Platform
   , listSupported
   , setDefault
   -- * Byte Order
   , getByteorder
   , getHeaderByteorder
   -- *
   , getObjectFlags
   , getSectionFlags
   , Bindings.Bfd.Target.getFlavour
   , getName
   -- ** Symtabs
   , getSymtabUpperBound
   , canonicalizeSymtab
   , getDynamicSymtabUpperBound
   , canonicalizeDynamicSymtab
   , getSyntheticSymtab
   -- ** Relocations
   , getDynamicRelocUpperBound
   , canonicalizeDynamicReloc
   -- * Testing
   -- ** Byte Order
   , isBigEndian
   , isLittleEndian
   , isHeaderBigEndian
   , isHeaderLittleEndian
   -- ** Coff Family
   , isCoffFamily
   -- *
   , getPrintSymbol
   -- * Internal
   , Target'
) where

import Data.Bits
import Data.Word

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

import {-# SOURCE #-} Bindings.Bfd
import                Bindings.Bfd.Endian
import                Bindings.Bfd.Exception
import                Bindings.Bfd.Flags         as BfdFlags
import                Bindings.Bfd.Flavour
import                Bindings.Bfd.Misc
import {-# SOURCE #-} Bindings.Bfd.Relocation
import                Bindings.Bfd.Section.Flags as SectionFlags
import {-# SOURCE #-} Bindings.Bfd.Symbol        as Symbol
import {-# SOURCE #-} Bindings.Bfd.SymbolTable

#include <bfd.h>


type TargetName = String

type Target = Ptr Target'

data Target' = Name                       TargetName
             | Flavour                    Flavour
             | Byteorder                  Endian
             | HeaderByteorder            Endian
             | ObjectFlags                [BfdFlags.Flags]
             | SectionFlags               [SectionFlags.Flags]
             | GetSymtabUpperBound        (FunPtr (Ptr Bfd' -> IO CLong))
             | CanonicalizeSymtab         (FunPtr (Ptr Bfd' -> Ptr Symbol -> IO CLong))
             | PrintSymbol                (FunPtr (Ptr Bfd' -> File -> Symbol -> CUInt -> IO ()))
             | GetDynamicSymtabUpperBound (FunPtr (Ptr Bfd' -> IO CLong))
             | CanonicalizeDynamicSymtab  (FunPtr (Ptr Bfd' -> Ptr Symbol -> IO CLong))
             | GetSyntheticSymtab         (FunPtr (Ptr Bfd' -> CLong -> Ptr Symbol -> CLong -> Ptr Symbol -> Ptr Symbol -> IO CLong))
             | GetDynamicRelocUpperBound  (FunPtr (Ptr Bfd' -> IO CLong))
             | CanonicalizeDynamicReloc   (FunPtr (Ptr Bfd' -> Ptr (Ptr Relocation) -> Ptr Symbol -> IO CLong))
     deriving (Show)

instance Storable Target' where
   sizeOf _ = #size struct bfd_target
   alignment = sizeOf
   peekByteOff buf off
      | off == (#offset struct bfd_target, name) =
         do
            val <- (#peek struct bfd_target, name) buf
            s   <- peekCString val
            return $ Bindings.Bfd.Target.Name s
      | off == (#offset struct bfd_target, flavour) =
         do
            val <- (#peek struct bfd_target, flavour) buf :: IO CUInt
            return $ Flavour $ toEnum $ fromIntegral val
      | off == (#offset struct bfd_target, byteorder) =
         do
            val <- (#peek struct bfd_target, byteorder) buf :: IO CUInt
            return $ Byteorder $ toEnum $ fromIntegral val
      | off == (#offset struct bfd_target, header_byteorder) =
         do
            val <- (#peek struct bfd_target, header_byteorder) buf :: IO CUInt
            return $ HeaderByteorder $ toEnum $ fromIntegral val
      | off == (#offset struct bfd_target, object_flags) =
         do
            val <- (#peek struct bfd_target, object_flags) buf :: IO CUInt
            let
               flags = filter f $ enumFrom HasReloc
                  where
                     f e = val .&. (bit $ fromEnum e) /= 0
            return $ ObjectFlags flags
      | off == (#offset struct bfd_target, section_flags) =
         do
            val <- (#peek struct bfd_target, section_flags) buf :: IO CUInt
            let
               flags = filter f $ enumFrom Alloc
                  where
                     f e = val .&. (bit $ fromEnum e) /= 0
            return $ SectionFlags flags
      | off == (#offset struct bfd_target, _bfd_get_symtab_upper_bound) =
         do
            val <- (#peek struct bfd_target, _bfd_get_symtab_upper_bound) buf :: IO Word
            return $ GetSymtabUpperBound $ castPtrToFunPtr $ wordPtrToPtr $ fromIntegral val
      | off == (#offset struct bfd_target, _bfd_canonicalize_symtab) =
         do
            val <- (#peek struct bfd_target, _bfd_canonicalize_symtab) buf :: IO Word
            return $ CanonicalizeSymtab $ castPtrToFunPtr $ wordPtrToPtr $ fromIntegral val
      | off == (#offset struct bfd_target, _bfd_print_symbol) =
         do
            val <- (#peek struct bfd_target, _bfd_print_symbol) buf :: IO Word
            return $ PrintSymbol $ castPtrToFunPtr $ wordPtrToPtr $ fromIntegral val
      | off == (#offset struct bfd_target, _bfd_get_dynamic_symtab_upper_bound) =
         do
            val <- (#peek struct bfd_target, _bfd_get_dynamic_symtab_upper_bound) buf :: IO Word
            return $ GetDynamicSymtabUpperBound $ castPtrToFunPtr $ wordPtrToPtr $ fromIntegral val
      | off == (#offset struct bfd_target, _bfd_canonicalize_dynamic_symtab) =
         do
            val <- (#peek struct bfd_target, _bfd_canonicalize_dynamic_symtab) buf :: IO Word
            return $ CanonicalizeDynamicSymtab $ castPtrToFunPtr $ wordPtrToPtr $ fromIntegral val
      | off == (#offset struct bfd_target, _bfd_get_synthetic_symtab) =
         do
            val <- (#peek struct bfd_target, _bfd_get_synthetic_symtab) buf :: IO Word
            return $ GetSyntheticSymtab $ castPtrToFunPtr $ wordPtrToPtr $ fromIntegral val
      | off == (#offset struct bfd_target, _bfd_get_dynamic_reloc_upper_bound) =
         do
            val <- (#peek struct bfd_target, _bfd_get_dynamic_reloc_upper_bound) buf :: IO Word
            return $ GetDynamicRelocUpperBound $ castPtrToFunPtr $ wordPtrToPtr $ fromIntegral val
      | off == (#offset struct bfd_target, _bfd_canonicalize_dynamic_reloc) =
         do
            val <- (#peek struct bfd_target, _bfd_canonicalize_dynamic_reloc) buf :: IO Word
            return $ CanonicalizeDynamicReloc $ castPtrToFunPtr $ wordPtrToPtr $ fromIntegral val
      | otherwise = error $ "internal error: Bfd.Target.peekByteOff " ++ show off


-- | Return a list of target names that can possibly be interpreted by this
-- particular platform.
listSupported
   :: IO [TargetName]
listSupported = 
   do
      let
         pts = c_bfd_target_list
      ps <- peekArray0 nullPtr pts
      res <- mapM peekCString ps
      free pts                       -- FIXME is this dodgy?
      return res

-- | Set the default target name for use with 'open' etc. when 'TargetName' is
-- equal to \"default\" or empty.  Returns 'True' if successful.
--
-- /Possible exceptions:/ 'InvalidTarget'
setDefault
   :: TargetName
   -> IO Bool
setDefault tn =
   do
      r <- withCString tn (\s -> c_bfd_set_default_target s)
      throwExceptionIfFalse "setDefault" tn (return $ toBool r)

getByteorder
   :: Target
   -> IO Endian
getByteorder targ =
   do
      bo <- peekByteOff targ (#offset struct bfd_target, byteorder)
      return $ unTarget'Byteorder bo

getHeaderByteorder
   :: Target
   -> IO Endian
getHeaderByteorder targ =
   do
      bo <- peekByteOff targ (#offset struct bfd_target, header_byteorder)
      return $ unTarget'HeaderByteorder bo

getObjectFlags
   :: Target
   -> IO [BfdFlags.Flags]
getObjectFlags targ =
   do
      f <- peekByteOff targ (#offset struct bfd_target, object_flags)
      return $ unTarget'ObjectFlags f

getSectionFlags
   :: Target
   -> IO [SectionFlags.Flags]
getSectionFlags targ =
   do
      f <- peekByteOff targ (#offset struct bfd_target, section_flags)
      return $ unTarget'SectionFlags f

getFlavour
   :: Target
   -> IO Flavour
getFlavour targ =
   do
      flav <- peekByteOff targ (#offset struct bfd_target, flavour)
      return $ unTarget'Flavour flav

getName
   :: Target
   -> IO TargetName
getName targ =
   do
      tn <- peekByteOff targ (#offset struct bfd_target, name)
      let
         tn' = unTarget'Name tn
      return tn'


getSymtabUpperBound
   :: Target
   -> Bfd
   -> IO Int
getSymtabUpperBound targ bfd =
   do
      fn <- peekByteOff targ (#offset struct bfd_target, _bfd_get_symtab_upper_bound)
      r <- d_Bfd_CLong (unTarget'GetSymtabUpperBound fn) $ ptr bfd
      return $ fromIntegral r

canonicalizeSymtab
   :: Target
   -> Bfd
   -> Ptr Symbol
   -> IO Int
canonicalizeSymtab targ bfd ps =
   do
      fn <- peekByteOff targ (#offset struct bfd_target, _bfd_canonicalize_symtab)
      r <- d_Bfd_PtrSymbol_CLong (unTarget'CanonicalizeSymtab fn) (ptr bfd) ps
      return $ fromIntegral r

getDynamicSymtabUpperBound
   :: Target
   -> Bfd
   -> IO Int
getDynamicSymtabUpperBound targ bfd =
   do
      fn <- peekByteOff targ (#offset struct bfd_target, _bfd_get_dynamic_symtab_upper_bound)
      r <- d_Bfd_CLong (unTarget'GetDynamicSymtabUpperBound fn) (ptr bfd)
      return $ fromIntegral r

canonicalizeDynamicSymtab
   :: Target
   -> Bfd
   -> Ptr Symbol
   -> IO Int
canonicalizeDynamicSymtab targ bfd ps =
   do
      fn <- peekByteOff targ (#offset struct bfd_target, _bfd_canonicalize_dynamic_symtab)
      r <- d_Bfd_PtrSymbol_CLong (unTarget'CanonicalizeDynamicSymtab fn) (ptr bfd) ps
      return $ fromIntegral r

getSyntheticSymtab
   :: Target
   -> Bfd
   -> SymbolTable
   -> SymbolTable
   -> Ptr Symbol
   -> IO Int
getSyntheticSymtab targ bfd sst dst synth =
   do
      fn <- peekByteOff targ (#offset struct bfd_target, _bfd_get_synthetic_symtab)
      r <- d_Bfd_CLong_PtrSymbol_CLong_PtrSymbol_PtrSymbol_CLong (fn' fn) (ptr bfd) sts stp dts dtp synth
      return $ fromIntegral r
   where
      fn' = unTarget'GetSyntheticSymtab
      sts = fromIntegral $ tableSize sst
      stp = tablePtr sst
      dts = fromIntegral $ tableSize dst
      dtp = tablePtr dst

getDynamicRelocUpperBound
   :: Target
   -> Bfd
   -> IO Int
getDynamicRelocUpperBound targ bfd =
   do
      fn <- peekByteOff targ (#offset struct bfd_target, _bfd_get_dynamic_reloc_upper_bound)
      r <- d_Bfd_CLong (unTarget'GetDynamicRelocUpperBound fn) (ptr bfd)
      return $ fromIntegral r

canonicalizeDynamicReloc
   :: Target
   -> Bfd
   -> Ptr (Ptr Relocation)
   -> Ptr Symbol
   -> IO Int
canonicalizeDynamicReloc targ bfd rels syms =
   do
      fn <- peekByteOff targ (#offset struct bfd_target, _bfd_canonicalize_dynamic_reloc)
      r <- d_Bfd_PtrPtrRelocation_PtrSymbol_CLong (unTarget'CanonicalizeDynamicReloc fn) (ptr bfd) rels syms
      return $ fromIntegral r

-- Testing =====================================================================
-- Byte Order ------------------------------------------------------------------

-- | Returns 'True' if the 'Target's byte order (see 'getByteorder') is 'Big'.
-- Otherwise 'False'.
isBigEndian
   :: Target
   -> IO Bool
isBigEndian targ =
   do
      bo <- getByteorder targ
      return $ bo == Big

-- | Returns 'True' if the 'Target's byte order (see 'getByteorder') is 'Little'.
-- Otherwise 'False'.
isLittleEndian
   :: Target
   -> IO Bool
isLittleEndian targ =
   do
      bo <- getByteorder targ
      return $ bo == Little

-- | Returns 'True' if the 'Target's header byte order (see 'getHeaderByteOrder')
-- is 'Big'.  Otherwise 'False'.
isHeaderBigEndian
   :: Target
   -> IO Bool
isHeaderBigEndian targ =
   do
      bo <- getHeaderByteorder targ
      return $ bo == Big

-- | Returns 'True' if the 'Target's header byte order (see 'getHeaderByteOrder')
-- is 'Little'.  Otherwise 'False'.
isHeaderLittleEndian
   :: Target
   -> IO Bool
isHeaderLittleEndian targ =
   do
      bo <- getHeaderByteorder targ
      return $ bo == Little

-- Coff Family -----------------------------------------------------------------

-- | Returns 'True' if the 'Flavour' of the 'Target' is either 'Coff' or 'Xcoff'.
--  Otherwise 'False'.
isCoffFamily
   :: Target
   -> IO Bool
isCoffFamily targ =
   do
      flav <- getFlavour targ
      return $ flav == Coff || flav == Xcoff

-- -----------------------------------------------------------------------------

unTarget'Name
   :: Target'
   -> TargetName
unTarget'Name (Bindings.Bfd.Target.Name s) = s
unTarget'Name _                            = error "unTarget'Name"

unTarget'Flavour
   :: Target'
   -> Flavour
unTarget'Flavour (Flavour f) = f
unTarget'Flavour _           = error "unTarget'Flavour"

unTarget'Byteorder
   :: Target'
   -> Endian
unTarget'Byteorder (Byteorder b) = b
unTarget'Byteorder _             = error "unTarget'Byteorder"

unTarget'HeaderByteorder
   :: Target'
   -> Endian
unTarget'HeaderByteorder (HeaderByteorder b) = b
unTarget'HeaderByteorder _                   = error "unTarget'HeaderByteorder"

unTarget'ObjectFlags
   :: Target'
   -> [BfdFlags.Flags]
unTarget'ObjectFlags (ObjectFlags b) = b
unTarget'ObjectFlags _               = error "unTarget'ObjectFlags"

unTarget'SectionFlags
   :: Target'
   -> [SectionFlags.Flags]
unTarget'SectionFlags (SectionFlags b) = b
unTarget'SectionFlags _                = error "unTarget'SectionFlags"

unTarget'GetSymtabUpperBound
   :: Target'
   -> FunPtr (Ptr Bfd' -> IO CLong)
unTarget'GetSymtabUpperBound (GetSymtabUpperBound fn) = fn
unTarget'GetSymtabUpperBound _                        = error "unTarget'GetSymtabUpperBound"

unTarget'CanonicalizeSymtab
   :: Target'
   -> FunPtr (Ptr Bfd' -> Ptr Symbol -> IO CLong)
unTarget'CanonicalizeSymtab (CanonicalizeSymtab fn) = fn
unTarget'CanonicalizeSymtab _                       = error "unTarget'CanonicalizeSymtab"

unTarget'GetDynamicSymtabUpperBound
   :: Target'
   -> FunPtr (Ptr Bfd' -> IO CLong)
unTarget'GetDynamicSymtabUpperBound (GetDynamicSymtabUpperBound fn) = fn
unTarget'GetDynamicSymtabUpperBound _                               = error "unTarget'GetDynamicSymtabUpperBound"

unTarget'CanonicalizeDynamicSymtab
   :: Target'
   -> FunPtr (Ptr Bfd' -> Ptr Symbol -> IO CLong)
unTarget'CanonicalizeDynamicSymtab (CanonicalizeDynamicSymtab fn) = fn
unTarget'CanonicalizeDynamicSymtab _                              = error "unTarget'CanonicalizeDynamicSymtab"

unTarget'GetSyntheticSymtab
   :: Target'
   -> FunPtr (Ptr Bfd' -> CLong -> Ptr Symbol -> CLong -> Ptr Symbol -> Ptr Symbol -> IO CLong)
unTarget'GetSyntheticSymtab (GetSyntheticSymtab fn) = fn
unTarget'GetSyntheticSymtab _                       = error "unTarget'GetSyntheticSymtab"

unTarget'GetDynamicRelocUpperBound
   :: Target'
   -> FunPtr (Ptr Bfd' -> IO CLong)
unTarget'GetDynamicRelocUpperBound (GetDynamicRelocUpperBound fn) = fn
unTarget'GetDynamicRelocUpperBound _                              = error "unTarget'GetDynamicRelocUpperBound"

unTarget'CanonicalizeDynamicReloc
   :: Target'
   -> FunPtr (Ptr Bfd' -> Ptr (Ptr Relocation) -> Ptr Symbol -> IO CLong)
unTarget'CanonicalizeDynamicReloc (CanonicalizeDynamicReloc fn) = fn
unTarget'CanonicalizeDynamicReloc _                             = error "unTarget'CanonicalizeDynamicReloc"

unXVec2
   :: Target'
   -> FunPtr (Ptr Bfd' -> File -> Symbol -> CUInt -> IO ())
unXVec2 (PrintSymbol fn) = fn
unXVec2 x                = error $ "internal error: unXVec2 " ++ show x


getPrintSymbol
   :: Target
   -> Bfd
   -> File
   -> Symbol
   -> IO (IO ())
getPrintSymbol targ bfd file sym =
   do 
      fn <- peekByteOff targ (#offset struct bfd_target, _bfd_print_symbol)
      let
         f = d_Bfd_File_Symbol_CUInt_Void (unXVec2 fn) (ptr bfd) file sym 2
      return f

-- -----------------------------------------------------------------------------

foreign import ccall unsafe "bfd.h bfd_target_list" c_bfd_target_list
   :: Ptr CString

foreign import ccall unsafe "bfd.h bfd_set_default_target" c_bfd_set_default_target
   :: CString
   -> IO CInt

foreign import ccall unsafe "dynamic" d_Bfd_CLong
   :: FunPtr (Ptr Bfd' -> IO CLong)
   -> (Ptr Bfd' -> IO CLong)

foreign import ccall unsafe "dynamic" d_Bfd_CLong_PtrSymbol_CLong_PtrSymbol_PtrSymbol_CLong
   :: FunPtr (Ptr Bfd' -> CLong -> Ptr Symbol -> CLong -> Ptr Symbol -> Ptr Symbol -> IO CLong) 
   -> (Ptr Bfd' -> CLong -> Ptr Symbol -> CLong -> Ptr Symbol -> Ptr Symbol -> IO CLong)

foreign import ccall unsafe "dynamic" d_Bfd_PtrSymbol_CLong
   :: FunPtr (Ptr Bfd' -> Ptr Symbol -> IO CLong)
   -> (Ptr Bfd' -> Ptr Symbol -> IO CLong)

foreign import ccall unsafe "dynamic" d_Bfd_PtrPtrRelocation_PtrSymbol_CLong
   :: FunPtr (Ptr Bfd' -> Ptr (Ptr Relocation) -> Ptr Symbol -> IO CLong) 
   -> (Ptr Bfd' -> Ptr (Ptr Relocation) -> Ptr Symbol -> IO CLong)

foreign import ccall unsafe "dynamic" d_Bfd_File_Symbol_CUInt_Void
   :: FunPtr (Ptr Bfd' -> File -> Symbol -> CUInt -> IO ()) 
   -> (Ptr Bfd' -> File -> Symbol -> CUInt -> IO ())