Alignment.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Windll
-- Copyright   :  (c) Tamar Christina 2009 - 2010
-- License     :  BSD3
-- 
-- Maintainer  :  tamar@zhox.com
-- Stability   :  experimental
-- Portability :  portable
--
-- A helper module to use hsc2hs to resolve the proper sizes for the structures
-- By examening them on a by structure bases and getting the biggest structure out of it
-- and then adding the base structure. This because most types are expressed as unions
-- and thus require some extra memory to be allocated, now because GHC doesn't use the
-- value given to the sizeOf method, I can't accurately calculate the needed space for
-- any one particular call which leaves me with the only option of allocating enough
-- space everytime to keep the biggest structure in memory.
-----------------------------------------------------------------------------

module WinDll.Structs.MShow.Alignment (resolveAlignment) where

import System.IO
import System.IO.Unsafe
import System.Directory
import System.Process
import System.FilePath

import Control.Monad

import Data.List

import System.IO
import System.IO.Error
import Paths_Hs2lib

import qualified Debug.Trace as D

-- | Resolve the alignments by creating a temp hsc file to calculate the alignments
--   then clean them up. Because this call is not in the global local state (it's called from
--   inside MShow afterall, which isn't a monad) It will not be affected by the -T flag (keep temp file)
--   . 
--   It will just always delete it's temporary files immediately.
resolveAlignment :: String -> String -> String -> String -> [(String,Int)] -> Int
resolveAlignment path nspace ldir _name list = 
    let full     = _name : map fst list
        hsc      = createHSC nspace full
        (a:x:xs) = executeHSC path ldir _name hsc
        size     = x + foldl' max 0 xs
    in case size `mod` a of
         0 -> size
         _ -> size + (a - (size `mod` a))

-- | Create the actual HSC file with
createHSC :: String -> [String] -> String
createHSC name = \env -> ((("#include \""++name++".h\"\n")++) 
               . unlines 
               . ("#let alignment t = \"(%lu)\", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)":)
               . (("#alignment " ++ head env ++ "_t"):) 
               . map (\x->"#size "++x++"_t")) env

-- | Write the HSC file to disc, execute hsc2hs and read the value back in. This will be wrapped with
--   unsafeperform IO because again MShow is not a monad (perhaps it should be)
executeHSC :: String -> String -> String -> String -> [Int]
executeHSC path ldir name content = unsafePerformIO $ 
  do -- tempfile <- getTemporaryDirectory
     let infile   = name ++ ".in-align.hsc"
         outfile  = name ++ ".in-align.hs"
         
     ldir2 <- getDataFileName "Includes"  
     writeFile (path ++ infile) content
     handle   <- runProcess "hsc2hs" [infile
                                     , "-I" ++ addTrailingPathSeparator ldir ++ "Includes"
                                     , "-I" ++ ldir2] (Just path) Nothing Nothing Nothing Nothing
     exitcode <- waitForProcess handle
     result   <- liftM (map (fst . head . (readParen True reads :: String -> [(Int, String)])) . filter inline . lines) (readFile $ path ++ outfile)
        
     removeFile (path ++ infile)
     -- removeFile (path ++ outfile) -- fix the stupid locking IO
     
     return result
     
       where inline ('(':_) = True
             inline _       = False