CrossCodegen.hs

{-# LANGUAGE NoMonomorphismRestriction #-}

module CrossCodegen where

{-
A special cross-compilation mode for hsc2hs, which generates a .hs
file without needing to run the executables that the C compiler
outputs.

Instead, it uses the output of compilations only -- specifically,
whether compilation fails.  This is the same trick that autoconf uses
when cross compiling; if you want to know if sizeof(int) <= 4, then try
compiling:

> int x() {
>   static int ary[1 - 2*(sizeof(int) <= 4)];
> }

and see if it fails. If you want to know sizeof(int), then
repeatedly apply this kind of test with differing values, using
binary search.
-}

import Prelude hiding (concatMap)
import System.IO (hPutStr, openFile, IOMode(..), hClose)
import System.Directory (removeFile)
import Data.Char (toLower,toUpper,isSpace)
import Control.Exception (assert, onException)
import Control.Monad (when, liftM, forM, ap)
import Control.Applicative as AP (Applicative(..))
import Data.Foldable (concatMap)
import Data.Maybe (fromMaybe)
import qualified Data.Sequence as S
import Data.Sequence ((|>),ViewL(..))
import System.Exit ( ExitCode(..) )
import System.Process

import C
import Common
import Flags
import HSCParser

import qualified ATTParser as ATT

-- A monad over IO for performing tests; keeps the commandline flags
-- and a state counter for unique filename generation.
-- equivalent to ErrorT String (StateT Int (ReaderT TestMonadEnv IO))
newtype TestMonad a = TestMonad { runTest :: TestMonadEnv -> Int -> IO (Either String a, Int) }

instance Functor TestMonad where
    fmap = liftM

instance Applicative TestMonad where
    pure a = TestMonad (\_ c -> pure (Right a, c))
    (<*>) = ap

instance Monad TestMonad where
    return = AP.pure
    x >>= fn = TestMonad (\e c -> (runTest x e c) >>=
                                      (\(a,c') -> either (\err -> return (Left err, c'))
                                                         (\result -> runTest (fn result) e c')
                                                         a))

data TestMonadEnv = TestMonadEnv {
    testIsVerbose_ :: Bool,
    testLogNestCount_ :: Int,
    testKeepFiles_ :: Bool,
    testGetBaseName_ :: FilePath,
    testGetFlags_ :: [Flag],
    testGetConfig_ :: Config,
    testGetCompiler_ :: FilePath
}

testAsk :: TestMonad TestMonadEnv
testAsk = TestMonad (\e c -> return (Right e, c))

testIsVerbose :: TestMonad Bool
testIsVerbose = testIsVerbose_ `fmap` testAsk

testGetCompiler :: TestMonad FilePath
testGetCompiler = testGetCompiler_ `fmap` testAsk

testKeepFiles :: TestMonad Bool
testKeepFiles = testKeepFiles_ `fmap` testAsk

testGetFlags :: TestMonad [Flag]
testGetFlags = testGetFlags_ `fmap` testAsk

testGetConfig :: TestMonad Config
testGetConfig = testGetConfig_ `fmap` testAsk

testGetBaseName :: TestMonad FilePath
testGetBaseName = testGetBaseName_ `fmap` testAsk

testIncCount :: TestMonad Int
testIncCount = TestMonad (\_ c -> let next=succ c
                                  in next `seq` return (Right c, next))
testFail' :: String -> TestMonad a
testFail' s = TestMonad (\_ c -> return (Left s, c))

testFail :: SourcePos -> String -> TestMonad a
testFail (SourcePos file line _) s = testFail' (file ++ ":" ++ show line ++ " " ++ s)

-- liftIO for TestMonad
liftTestIO :: IO a -> TestMonad a
liftTestIO x = TestMonad (\_ c -> x >>= \r -> return (Right r, c))

-- finally for TestMonad
testFinally :: TestMonad a -> TestMonad b -> TestMonad a
testFinally action cleanup = do r <- action `testOnException` cleanup
                                _ <- cleanup
                                return r

-- onException for TestMonad. This rolls back the state on an
-- IO exception, which isn't great but shouldn't matter for now
-- since only the test count is stored there.
testOnException :: TestMonad a -> TestMonad b -> TestMonad a
testOnException action cleanup = TestMonad (\e c -> runTest action e c
                                                        `onException` runTest cleanup e c >>= \(actionResult,c') ->
                                                        case actionResult of
                                                           Left _ -> do (_,c'') <- runTest cleanup e c'
                                                                        return (actionResult,c'')
                                                           Right _ -> return (actionResult,c'))

-- prints the string to stdout if verbose mode is enabled.
-- Maintains a nesting count and pads with spaces so that:
-- testLog "a" $
--    testLog "b" $ return ()
-- will print
-- a
--     b
testLog :: String -> TestMonad a -> TestMonad a
testLog s a = TestMonad (\e c -> do let verbose = testIsVerbose_ e
                                        nestCount = testLogNestCount_ e
                                    when verbose $ putStrLn $ (concat $ replicate nestCount "    ") ++ s
                                    runTest a (e { testLogNestCount_ = nestCount+1 }) c)

testLog' :: String -> TestMonad ()
testLog' s = testLog s (return ())

testLogAtPos :: SourcePos -> String -> TestMonad a -> TestMonad a
testLogAtPos (SourcePos file line _) s a = testLog (file ++ ":" ++ show line ++ " " ++ s) a

-- Given a list of file suffixes, will generate a list of filenames
-- which are all unique and have the given suffixes. On exit from this
-- action, all those files will be removed (unless keepFiles is active)
makeTest :: [String] -> ([String] -> TestMonad a) -> TestMonad a
makeTest fileSuffixes fn = do
    c <- testIncCount
    fileBase <- testGetBaseName
    keepFiles <- testKeepFiles
    let files = zipWith (++) (repeat (fileBase ++ show c)) fileSuffixes
    testFinally (fn files)
                (when (not keepFiles)
                      (mapM_ removeOrIgnore files))
    where
     removeOrIgnore f = liftTestIO (catchIO (removeFile f) (const $ return ()))
-- Convert from lists to tuples (to avoid "incomplete pattern" warnings in the callers)
makeTest2 :: (String,String) -> ((String,String) -> TestMonad a) -> TestMonad a
makeTest2 (a,b) fn = makeTest [a,b] helper
    where helper [a',b'] = fn (a',b')
          helper _ = error "makeTest: internal error"
makeTest3 :: (String,String,String) -> ((String,String,String) -> TestMonad a) -> TestMonad a
makeTest3 (a,b,c) fn = makeTest [a,b,c] helper
    where helper [a',b',c'] = fn (a',b',c')
          helper _ = error "makeTest: internal error"

-- A Zipper over lists. Unlike ListZipper, this separates at the type level
-- a list which may have a currently focused item (Zipper a) from
-- a list which _definitely_ has a focused item (ZCursor a), so
-- that zNext can be total.
data Zipper a = End { zEnd :: S.Seq a }
              | Zipper (ZCursor a)

data ZCursor a = ZCursor { zCursor :: a,
                           zAbove :: S.Seq a, -- elements prior to the cursor
                                              -- in regular order (not reversed!)
                           zBelow :: S.Seq a -- elements after the cursor
                         }

zipFromList :: [a] -> Zipper a
zipFromList [] = End S.empty
zipFromList (l:ls) = Zipper (ZCursor l S.empty (S.fromList ls))

zNext :: ZCursor a -> Zipper a
zNext (ZCursor c above below) =
    case S.viewl below of
      S.EmptyL -> End (above |> c)
      c' :< below' -> Zipper (ZCursor c' (above |> c) below')

-- Generates the .hs file from the .hsc file, by looping over each
-- Special element and calling outputSpecial to find out what it needs.
diagnose :: String -> (String -> TestMonad ()) -> [Token] -> TestMonad ()
diagnose inputFilename output input = do
    checkValidity input
    output ("{-# LINE 1 \"" ++ inputFilename ++ "\" #-}\n")
    loop (True, True) (zipFromList input)

    where
    loop _ (End _) = return ()
    loop state@(lineSync, colSync)
         (Zipper z@ZCursor {zCursor=Special _ key _}) =
        case key of
            _ | key `elem` ["if","ifdef","ifndef","elif","else"] -> do
                condHolds <- checkConditional z
                if condHolds
                    then loop state (zNext z)
                    else loop state =<< either testFail' return
                                               (skipFalseConditional (zNext z))
            "endif" -> loop state (zNext z)
            _ -> do
                sync <- outputSpecial output z
                loop (lineSync && sync, colSync && sync) (zNext z)
    loop state (Zipper z@ZCursor {zCursor=Text pos txt}) = do
        state' <- outputText state output pos txt
        loop state' (zNext z)

outputSpecial :: (String -> TestMonad ()) -> ZCursor Token -> TestMonad Bool
outputSpecial output (z@ZCursor {zCursor=Special pos@(SourcePos file line _)  key value}) =
    case key of
       "const" -> outputConst value show >> return False
       "offset" -> outputConst ("offsetof(" ++ value ++ ")") (\i -> "(" ++ show i ++ ")") >> return False
       "size" -> outputConst ("sizeof(" ++ value ++ ")") (\i -> "(" ++ show i ++ ")") >> return False
       "alignment" -> outputConst (alignment value) show >> return False
       "peek" -> outputConst ("offsetof(" ++ value ++ ")")
                             (\i -> "(\\hsc_ptr -> peekByteOff hsc_ptr " ++ show i ++ ")") >> return False
       "poke" -> outputConst ("offsetof(" ++ value ++ ")")
                             (\i -> "(\\hsc_ptr -> pokeByteOff hsc_ptr " ++ show i ++ ")") >> return False
       "ptr" -> outputConst ("offsetof(" ++ value ++ ")")
                            (\i -> "(\\hsc_ptr -> hsc_ptr `plusPtr` " ++ show i ++ ")") >> return False
       "type" -> computeType z >>= output >> return False
       "enum" -> computeEnum z >>= output >> return False
       "error" -> testFail pos ("#error " ++ value)
       "warning" -> liftTestIO $ putStrLn (file ++ ":" ++ show line ++ " warning: " ++ value) >> return True
       "include" -> return True
       "define" -> return True
       "undef" -> return True
       _ -> testFail pos ("directive " ++ key ++ " cannot be handled in cross-compilation mode")
    where outputConst value' formatter = computeConst z value' >>= (output . formatter)
outputSpecial _ _ = error "outputSpecial's argument isn't a Special"

outputText :: (Bool, Bool) -> (String -> TestMonad ()) -> SourcePos -> String
           -> TestMonad (Bool, Bool)
outputText state output pos txt = do
    enableCol <- fmap cColumn testGetConfig
    let outCol col | enableCol = "{-# COLUMN " ++ show col ++ " #-}"
                   | otherwise = ""
    let outLine (SourcePos file line _) = "{-# LINE " ++ show (line + 1) ++
                                          " \"" ++ file ++ "\" #-}\n"
    let (s, state') = outTextHs state pos txt id outLine outCol
    output s
    return state'

-- Bleh, messy. For each test we're compiling, we have a specific line of
-- code that may cause compiler errors -- that's the test we want to perform.
-- However, we *really* don't want any other kinds of compiler errors sneaking
-- in (which might be e.g. due to the user's syntax errors) or we'll make the
-- wrong conclusions on our tests.
--
-- So before we compile any of the tests, take a pass over the whole file and
-- generate a .c file which should fail if there are any syntax errors in what
-- the user gaves us. Hopefully, then the only reason our later compilations
-- might fail is the particular reason we want.
--
-- Another approach would be to try to parse the stdout of GCC and diagnose
-- whether the error is the one we want. That's tricky because of localization
-- etc. etc., though it would be less nerve-wracking. FYI it's not the approach
-- that autoconf went with.
checkValidity :: [Token] -> TestMonad ()
checkValidity input = do
    config <- testGetConfig
    flags <- testGetFlags
    let test = outTemplateHeaderCProg (cTemplate config) ++
               concatMap outFlagHeaderCProg flags ++
               concatMap (uncurry (outValidityCheck (cViaAsm config))) (zip input [0..])
    testLog ("checking for compilation errors") $ do
        success <- makeTest2 (".c",".o") $ \(cFile,oFile) -> do
            liftTestIO $ writeBinaryFile cFile test
            compiler <- testGetCompiler
            runCompiler compiler
                        (["-S" | cViaAsm config ]++
                         ["-c",cFile,"-o",oFile]++
                         [f | CompFlag f <- flags])
                        Nothing
        when (not success) $ testFail' "compilation failed"
    testLog' "compilation is error-free"

outValidityCheck :: Bool -> Token -> Int -> String
outValidityCheck viaAsm s@(Special pos key value) uniq =
    case key of
       "const" -> checkValidConst value
       "offset" -> checkValidConst ("offsetof(" ++ value ++ ")")
       "size" -> checkValidConst ("sizeof(" ++ value ++ ")")
       "alignment" -> checkValidConst (alignment value)
       "peek" -> checkValidConst ("offsetof(" ++ value ++ ")")
       "poke" -> checkValidConst ("offsetof(" ++ value ++ ")")
       "ptr" -> checkValidConst ("offsetof(" ++ value ++ ")")
       "type" -> checkValidType
       "enum" -> checkValidEnum
       _ -> outHeaderCProg' s
    where
    checkValidConst value' = if viaAsm
                             then validConstTestViaAsm (show uniq) value' ++ "\n"
                             else "void _hsc2hs_test" ++ show uniq ++ "()\n{\n" ++ validConstTest value' ++ "}\n"
    checkValidType = "void _hsc2hs_test" ++ show uniq ++ "()\n{\n" ++ outCLine pos ++ "    (void)(" ++ value ++ ")1;\n}\n";
    checkValidEnum =
        case parseEnum value of
            Nothing -> ""
            Just (_,_,enums) | viaAsm ->
                concatMap (\(hName,cName) -> validConstTestViaAsm (fromMaybe "noKey" (ATT.trim `fmap` hName) ++ show uniq) cName) enums
            Just (_,_,enums) ->
                "void _hsc2hs_test" ++ show uniq ++ "()\n{\n" ++
                concatMap (\(_,cName) -> validConstTest cName) enums ++
                "}\n"

    -- we want this to fail if the value is syntactically invalid or isn't a constant
    validConstTest value' = outCLine pos ++ "    {\n        static int test_array[(" ++ value' ++ ") > 0 ? 2 : 1];\n        (void)test_array;\n    }\n"
    validConstTestViaAsm name value' = outCLine pos ++ "\nextern long long _hsc2hs_test_" ++ name ++";\n"
                                                    ++ "long long _hsc2hs_test_" ++ name ++ " = (" ++ value' ++ ");\n"

outValidityCheck _ (Text _ _) _ = ""

-- Skips over some #if or other conditional that we found to be false.
-- I.e. the argument should be a zipper whose cursor is one past the #if,
-- and returns a zipper whose cursor points at the next item which
-- could possibly be compiled.
skipFalseConditional :: Zipper Token -> Either String (Zipper Token)
skipFalseConditional (End _) = Left "unterminated endif"
skipFalseConditional (Zipper z@(ZCursor {zCursor=Special _ key _})) =
    case key of
      "if" -> either Left skipFalseConditional $ skipFullConditional 0 (zNext z)
      "ifdef" -> either Left skipFalseConditional $ skipFullConditional 0 (zNext z)
      "ifndef" -> either Left skipFalseConditional $ skipFullConditional 0 (zNext z)
      "elif" -> Right $ Zipper z
      "else" -> Right $ Zipper z
      "endif" -> Right $ zNext z
      _ -> skipFalseConditional (zNext z)
skipFalseConditional (Zipper z) = skipFalseConditional (zNext z)

-- Skips over an #if all the way to the #endif
skipFullConditional :: Int -> Zipper Token -> Either String (Zipper Token)
skipFullConditional _ (End _) = Left "unterminated endif"
skipFullConditional nest (Zipper z@(ZCursor {zCursor=Special _ key _})) =
    case key of
      "if" -> skipFullConditional (nest+1) (zNext z)
      "ifdef" -> skipFullConditional (nest+1) (zNext z)
      "ifndef" -> skipFullConditional (nest+1) (zNext z)
      "endif" | nest > 0 -> skipFullConditional (nest-1) (zNext z)
      "endif" | otherwise -> Right $ zNext z
      _ -> skipFullConditional nest (zNext z)
skipFullConditional nest (Zipper z) = skipFullConditional nest (zNext z)

data IntegerConstant = Signed Integer |
                       Unsigned Integer deriving (Show)
-- Prints an syntatically valid integer in C
cShowInteger :: IntegerConstant -> String
cShowInteger (Signed x) | x < 0 = "(" ++ show (x+1) ++ "-1)"
                                  -- Trick to avoid overflowing large integer constants
                                  -- http://www.hardtoc.com/archives/119
cShowInteger (Signed x) = show x
cShowInteger (Unsigned x) = show x ++ "u"

data IntegerComparison = GreaterOrEqual IntegerConstant |
                         LessOrEqual IntegerConstant
instance Show IntegerComparison where
    showsPrec _ (GreaterOrEqual c) = showString "`GreaterOrEqual` " . shows c
    showsPrec _ (LessOrEqual c) = showString "`LessOrEqual` " . shows c

cShowCmpTest :: IntegerComparison -> String
cShowCmpTest (GreaterOrEqual x) = ">=" ++ cShowInteger x
cShowCmpTest (LessOrEqual x) = "<=" ++ cShowInteger x

-- The cursor should point at #{const SOME_VALUE} or something like that.
-- Determines the value of SOME_VALUE using binary search; this
-- is a trick which is cribbed from autoconf's AC_COMPUTE_INT.
computeConst :: ZCursor Token -> String -> TestMonad Integer
computeConst zOrig@(ZCursor (Special pos _ _) _ _) value =
    testLogAtPos pos ("computing " ++ value) $ do
        config <- testGetConfig
        int <- case cViaAsm config of
                 True -> runCompileAsmIntegerTest z
                 False -> do nonNegative <- compareConst z (GreaterOrEqual (Signed 0))
                             integral <- checkValueIsIntegral z nonNegative
                             when (not integral) $ testFail pos $ value ++ " is not an integer"
                             (lower,upper) <- bracketBounds z nonNegative
                             binarySearch z nonNegative lower upper
        testLog' $ "result: " ++ show int
        return int
    where -- replace the Special's value with the provided value; e.g. the special
          -- is #{size SOMETHING} and we might replace value with "sizeof(SOMETHING)".
          z = zOrig {zCursor=specialSetValue value (zCursor zOrig)}
          specialSetValue v (Special p k _) = Special p k v
          specialSetValue _ _ = error "computeConst argument isn't a Special"
computeConst _ _ = error "computeConst argument isn't a Special"

-- Binary search, once we've bracketed the integer.
binarySearch :: ZCursor Token -> Bool -> Integer -> Integer -> TestMonad Integer
binarySearch _ _ l u | l == u = return l
binarySearch z nonNegative l u = do
    let mid :: Integer
        mid = (l+u+1) `div` 2
    inTopHalf <- compareConst z (GreaterOrEqual $ (if nonNegative then Unsigned else Signed) mid)
    let (l',u') = if inTopHalf then (mid,u) else (l,(mid-1))
    assert (l < mid && mid <= u &&             -- @l < mid <= u@
            l <= l' && l' <= u' && u' <= u &&  -- @l <= l' <= u' <= u@
            u'-l' < u-l)                       -- @|u' - l'| < |u - l|@
           (binarySearch z nonNegative l' u')

-- Establishes bounds on the unknown integer. By searching increasingly
-- large powers of 2, it'll bracket an integer x by lower & upper
-- such that lower <= x <= upper.
--
-- Assumes 2's complement integers.
bracketBounds :: ZCursor Token -> Bool -> TestMonad (Integer, Integer)
bracketBounds z nonNegative = do
    let -- test against integers 2**x-1 when positive, and 2**x when negative,
        -- to avoid generating constants that'd overflow the machine's integers.
        -- I.e. suppose we're searching for #{const INT_MAX} (e.g. 2^32-1).
        -- If we're comparing against all 2**x-1, we'll stop our search
        -- before we ever overflow int.
        powersOfTwo = iterate (\a -> 2*a) 1
        positiveBounds = map pred powersOfTwo
        negativeBounds = map negate powersOfTwo

        -- Test each element of the bounds list until we find one that exceeds
        -- the integer.
        loop cmp inner (maybeOuter:bounds') = do
          outerBounded <- compareConst z (cmp maybeOuter)
          if outerBounded
            then return (inner,maybeOuter)
            else loop cmp maybeOuter bounds'
        loop _ _ _ = error "bracketBounds: infinite list exhausted"

    if nonNegative
      then do (inner,outer) <- loop (LessOrEqual . Unsigned) (-1) positiveBounds
              return (inner+1,outer)
      else do (inner,outer) <- loop (GreaterOrEqual . Signed) 0 negativeBounds
              return (outer,inner-1)

-- For #{enum} codegen; mimics template-hsc.h's hsc_haskellize
haskellize :: String -> String
haskellize [] = []
haskellize (firstLetter:next) = toLower firstLetter : loop False next
    where loop _ [] = []
          loop _ ('_':as) = loop True as
          loop upper (a:as) = (if upper then toUpper a else toLower a) : loop False as

-- For #{enum} codegen; in normal hsc2hs, any whitespace in the enum types &
-- constructors will be mangled by the C preprocessor. This mimics the same
-- mangling.
stringify :: String -> String
-- Spec: stringify = unwords . words
stringify = go False . dropWhile isSpace
  where
    go _haveSpace [] = []
    go  haveSpace (x:xs)
      | isSpace x = go True xs
      | otherwise = if haveSpace
                    then ' ' : x : go False xs
                    else x : go False xs

-- For #{alignment} codegen; mimic's template-hsc.h's hsc_alignment
alignment :: String -> String
alignment t = "offsetof(struct {char x__; " ++ t ++ " (y__); }, y__)"

computeEnum :: ZCursor Token -> TestMonad String
computeEnum z@(ZCursor (Special _ _ enumText) _ _) =
    case parseEnum enumText of
        Nothing -> return ""
        Just (enumType,constructor,enums) ->
            concatM enums $ \(maybeHsName, cName) -> do
                constValue <- computeConst z cName
                let hsName = fromMaybe (haskellize cName) maybeHsName
                return $
                    hsName ++ " :: " ++ stringify enumType ++ "\n" ++
                    hsName ++ " = " ++ stringify constructor ++ " " ++ showsPrec 11 constValue "\n"
    where concatM l = liftM concat . forM l
computeEnum _ = error "computeEnum argument isn't a Special"

-- Implementation of #{type}, using computeConst
computeType :: ZCursor Token -> TestMonad String
computeType z@(ZCursor (Special pos _ value) _ _) = do
    testLogAtPos pos ("computing type of " ++ value) $ do
        integral <- testLog ("checking if type " ++ value ++ " is an integer") $ do
            success <- runCompileBooleanTest z $ "(" ++ value ++ ")(int)(" ++ value ++ ")1.4 == (" ++ value ++ ")1.4"
            testLog' $ "result: " ++ (if success then "integer" else "floating")
            return success
        typeRet <- if integral
         then do
            signed <- testLog ("checking if type " ++ value ++ " is signed") $ do
                success <- runCompileBooleanTest z $ "(" ++ value ++ ")(-1) < (" ++ value ++ ")0"
                testLog' $ "result: " ++ (if success then "signed" else "unsigned")
                return success
            size <- computeConst z ("sizeof(" ++ value ++ ")")
            return $ (if signed then "Int" else "Word") ++ (show (size * 8))
         else do
            let checkSize test = testLog ("checking if " ++ test) $ do
                    success <- runCompileBooleanTest z test
                    testLog' $ "result: " ++ show success
                    return success
            ldouble <- checkSize ("sizeof(" ++ value ++ ") > sizeof(double)")
            if ldouble
             then return "LDouble"
             else do
                double <- checkSize ("sizeof(" ++ value ++ ") == sizeof(double)")
                if double
                 then return "Double"
                 else return "Float"
        testLog' $ "result: " ++ typeRet
        return typeRet
computeType _ = error "computeType argument isn't a Special"

outHeaderCProg' :: Token -> String
outHeaderCProg' (Special pos key value) = outHeaderCProg (pos,key,value)
outHeaderCProg' _ = ""

-- Checks if an #if/#ifdef etc. etc. is true by inserting a #error
-- and seeing if the compile fails.
checkConditional :: ZCursor Token -> TestMonad Bool
checkConditional (ZCursor s@(Special pos key value) above below) = do
    config <- testGetConfig
    flags <- testGetFlags
    let test = outTemplateHeaderCProg (cTemplate config) ++
               (concatMap outFlagHeaderCProg flags) ++
               (concatMap outHeaderCProg' above) ++
               outHeaderCProg' s ++ "#error T\n" ++
               (concatMap outHeaderCProg' below)
    testLogAtPos pos ("checking #" ++ key ++ " " ++ value) $ do
        condTrue <- not `fmap` runCompileTest test
        testLog' $ "result: " ++ show condTrue
        return condTrue
checkConditional _ = error "checkConditional argument isn't a Special"

-- Make sure the value we're trying to binary search isn't floating point.
checkValueIsIntegral :: ZCursor Token -> Bool -> TestMonad Bool
checkValueIsIntegral z@(ZCursor (Special _ _ value) _ _) nonNegative = do
    let intType = if nonNegative then "unsigned long long" else "long long"
    testLog ("checking if " ++ value ++ " is an integer") $ do
        success <- runCompileBooleanTest z $ "(" ++ intType ++ ")(" ++ value ++ ") == (" ++ value ++ ")"
        testLog' $ "result: " ++ (if success then "integer" else "floating")
        return success
checkValueIsIntegral _ _ = error "checkConditional argument isn't a Special"

compareConst :: ZCursor Token -> IntegerComparison -> TestMonad Bool
compareConst z@(ZCursor (Special _ _ value) _ _) cmpTest = do
    testLog ("checking " ++ value ++ " " ++ show cmpTest) $ do
        success <- runCompileBooleanTest z $ "(" ++ value ++ ") " ++ cShowCmpTest cmpTest
        testLog' $ "result: " ++ show success
        return success
compareConst _ _ = error "compareConst argument isn't a Special"

-- Given a compile-time constant with boolean type, this extracts the
-- value of the constant by compiling a .c file only.
--
-- The trick comes from autoconf: use the fact that the compiler must
-- perform constant arithmetic for computation of array dimensions, and
-- will generate an error if the array has negative size.
runCompileBooleanTest :: ZCursor Token -> String -> TestMonad Bool
runCompileBooleanTest (ZCursor s above below) booleanTest = do
    config <- testGetConfig
    flags <- testGetFlags
    let test = -- all the surrounding code
               outTemplateHeaderCProg (cTemplate config) ++
               (concatMap outFlagHeaderCProg flags) ++
               (concatMap outHeaderCProg' above) ++
               outHeaderCProg' s ++
               -- the test
               "int _hsc2hs_test() {\n" ++
               "  static int test_array[1 - 2 * !(" ++ booleanTest ++ ")];\n" ++
               "  return test_array[0];\n" ++
               "}\n" ++
               (concatMap outHeaderCProg' below)
    runCompileTest test

runCompileAsmIntegerTest :: ZCursor Token -> TestMonad Integer
runCompileAsmIntegerTest (ZCursor s@(Special _ _ value) above below) = do
    config <- testGetConfig
    flags <- testGetFlags
    let key = "___hsc2hs_int_test"
    let test = -- all the surrounding code
               outTemplateHeaderCProg (cTemplate config) ++
               (concatMap outFlagHeaderCProg flags) ++
               (concatMap outHeaderCProg' above) ++
               outHeaderCProg' s ++
               -- the test
               "extern unsigned long long ___hsc2hs_BOM___;\n" ++
               "unsigned long long ___hsc2hs_BOM___ = 0x100000000;\n" ++
               "extern unsigned long long " ++ key ++ "___hsc2hs_sign___;\n" ++
               "unsigned long long " ++ key ++ "___hsc2hs_sign___ = (" ++ value ++ ") < 0;\n" ++
               "extern unsigned long long " ++ key ++ ";\n" ++
               "unsigned long long " ++ key ++ " = (" ++ value ++ ");\n"++
               (concatMap outHeaderCProg' below)
    runCompileExtract key test
runCompileAsmIntegerTest _ = error "runCompileAsmIntegerTestargument isn't a Special"

runCompileExtract :: String -> String -> TestMonad Integer
runCompileExtract k testStr = do
    makeTest3 (".c", ".s", ".txt") $ \(cFile, sFile, stdout) -> do
      liftTestIO $ writeBinaryFile cFile testStr
      flags <- testGetFlags
      compiler <- testGetCompiler
      _ <- runCompiler compiler
                  (["-S", "-c", cFile, "-o", sFile] ++ [f | CompFlag f <- flags])
                  (Just stdout)
      asm <- liftTestIO $ ATT.parse sFile
      return $ fromMaybe (error "Failed to extract integer") (ATT.lookupInteger k asm)

runCompileTest :: String -> TestMonad Bool
runCompileTest testStr = do
    makeTest3 (".c", ".o",".txt") $ \(cFile,oFile,stdout) -> do
      liftTestIO $ writeBinaryFile cFile testStr
      flags <- testGetFlags
      compiler <- testGetCompiler
      runCompiler compiler
                  (["-c",cFile,"-o",oFile]++[f | CompFlag f <- flags])
                  (Just stdout)

runCompiler :: FilePath -> [String] -> Maybe FilePath -> TestMonad Bool
runCompiler prog args mStdoutFile = do
  let cmdLine = showCommandForUser prog args
  testLog ("executing: " ++ cmdLine) $ liftTestIO $ do
      mHOut <- case mStdoutFile of
               Nothing -> return Nothing
               Just stdoutFile -> liftM Just $ openFile stdoutFile WriteMode
      process <- runProcess prog args Nothing Nothing Nothing mHOut mHOut
      case mHOut of
          Just hOut -> hClose hOut
          Nothing -> return ()
      exitStatus <- waitForProcess process
      return $ case exitStatus of
                 ExitSuccess -> True
                 ExitFailure _ -> False

-- The main driver for cross-compilation mode
outputCross :: Config -> String -> String -> String -> String -> [Token] -> IO ()
outputCross config outName outDir outBase inName toks =
    runTestMonad $ do
        file <- liftTestIO $ openFile outName WriteMode
        (diagnose inName (liftTestIO . hPutStr file) toks
           `testFinally` (liftTestIO $ hClose file))
           `testOnException` (liftTestIO $ removeFile outName) -- cleanup on errors
    where
    tmenv = TestMonadEnv (cVerbose config) 0 (cKeepFiles config) (outDir++outBase++"_hsc_test") (cFlags config) config (cCompiler config)
    runTestMonad x = runTest x tmenv 0 >>= (handleError . fst)

    handleError (Left e) = die (e++"\n")
    handleError (Right ()) = return ()