Fix type signature of main test function
[hsc2hs.git] / CrossCodegen.hs
1 {-# LANGUAGE NoMonomorphismRestriction #-}
2
3 module CrossCodegen where
4
5 {-
6 A special cross-compilation mode for hsc2hs, which generates a .hs
7 file without needing to run the executables that the C compiler
8 outputs.
9
10 Instead, it uses the output of compilations only -- specifically,
11 whether compilation fails. This is the same trick that autoconf uses
12 when cross compiling; if you want to know if sizeof(int) <= 4, then try
13 compiling:
14
15 > int x() {
16 > static int ary[1 - 2*(sizeof(int) <= 4)];
17 > }
18
19 and see if it fails. If you want to know sizeof(int), then
20 repeatedly apply this kind of test with differing values, using
21 binary search.
22 -}
23
24 import Prelude hiding (concatMap)
25 import System.IO (hPutStr, openFile, IOMode(..), hClose)
26 import System.Directory (removeFile)
27 import Data.Char (toLower,toUpper,isSpace)
28 import Control.Exception (assert, onException)
29 import Control.Monad (when, liftM, forM, ap)
30 import Control.Applicative as AP (Applicative(..))
31 import Data.Foldable (concatMap)
32 import Data.Maybe (fromMaybe)
33 import qualified Data.Sequence as S
34 import Data.Sequence ((|>),ViewL(..))
35 import System.Exit ( ExitCode(..) )
36 import System.Process
37
38 import C
39 import Common
40 import Flags
41 import HSCParser
42
43 -- A monad over IO for performing tests; keeps the commandline flags
44 -- and a state counter for unique filename generation.
45 -- equivalent to ErrorT String (StateT Int (ReaderT TestMonadEnv IO))
46 newtype TestMonad a = TestMonad { runTest :: TestMonadEnv -> Int -> IO (Either String a, Int) }
47
48 instance Functor TestMonad where
49 fmap = liftM
50
51 instance Applicative TestMonad where
52 pure a = TestMonad (\_ c -> pure (Right a, c))
53 (<*>) = ap
54
55 instance Monad TestMonad where
56 return = AP.pure
57 x >>= fn = TestMonad (\e c -> (runTest x e c) >>=
58 (\(a,c') -> either (\err -> return (Left err, c'))
59 (\result -> runTest (fn result) e c')
60 a))
61
62 data TestMonadEnv = TestMonadEnv {
63 testIsVerbose_ :: Bool,
64 testLogNestCount_ :: Int,
65 testKeepFiles_ :: Bool,
66 testGetBaseName_ :: FilePath,
67 testGetFlags_ :: [Flag],
68 testGetConfig_ :: Config,
69 testGetCompiler_ :: FilePath
70 }
71
72 testAsk :: TestMonad TestMonadEnv
73 testAsk = TestMonad (\e c -> return (Right e, c))
74
75 testIsVerbose :: TestMonad Bool
76 testIsVerbose = testIsVerbose_ `fmap` testAsk
77
78 testGetCompiler :: TestMonad FilePath
79 testGetCompiler = testGetCompiler_ `fmap` testAsk
80
81 testKeepFiles :: TestMonad Bool
82 testKeepFiles = testKeepFiles_ `fmap` testAsk
83
84 testGetFlags :: TestMonad [Flag]
85 testGetFlags = testGetFlags_ `fmap` testAsk
86
87 testGetConfig :: TestMonad Config
88 testGetConfig = testGetConfig_ `fmap` testAsk
89
90 testGetBaseName :: TestMonad FilePath
91 testGetBaseName = testGetBaseName_ `fmap` testAsk
92
93 testIncCount :: TestMonad Int
94 testIncCount = TestMonad (\_ c -> let next=succ c
95 in next `seq` return (Right c, next))
96 testFail' :: String -> TestMonad a
97 testFail' s = TestMonad (\_ c -> return (Left s, c))
98
99 testFail :: SourcePos -> String -> TestMonad a
100 testFail (SourcePos file line) s = testFail' (file ++ ":" ++ show line ++ " " ++ s)
101
102 -- liftIO for TestMonad
103 liftTestIO :: IO a -> TestMonad a
104 liftTestIO x = TestMonad (\_ c -> x >>= \r -> return (Right r, c))
105
106 -- finally for TestMonad
107 testFinally :: TestMonad a -> TestMonad b -> TestMonad a
108 testFinally action cleanup = do r <- action `testOnException` cleanup
109 _ <- cleanup
110 return r
111
112 -- onException for TestMonad. This rolls back the state on an
113 -- IO exception, which isn't great but shouldn't matter for now
114 -- since only the test count is stored there.
115 testOnException :: TestMonad a -> TestMonad b -> TestMonad a
116 testOnException action cleanup = TestMonad (\e c -> runTest action e c
117 `onException` runTest cleanup e c >>= \(actionResult,c') ->
118 case actionResult of
119 Left _ -> do (_,c'') <- runTest cleanup e c'
120 return (actionResult,c'')
121 Right _ -> return (actionResult,c'))
122
123 -- prints the string to stdout if verbose mode is enabled.
124 -- Maintains a nesting count and pads with spaces so that:
125 -- testLog "a" $
126 -- testLog "b" $ return ()
127 -- will print
128 -- a
129 -- b
130 testLog :: String -> TestMonad a -> TestMonad a
131 testLog s a = TestMonad (\e c -> do let verbose = testIsVerbose_ e
132 nestCount = testLogNestCount_ e
133 when verbose $ putStrLn $ (concat $ replicate nestCount " ") ++ s
134 runTest a (e { testLogNestCount_ = nestCount+1 }) c)
135
136 testLog' :: String -> TestMonad ()
137 testLog' s = testLog s (return ())
138
139 testLogAtPos :: SourcePos -> String -> TestMonad a -> TestMonad a
140 testLogAtPos (SourcePos file line) s a = testLog (file ++ ":" ++ show line ++ " " ++ s) a
141
142 -- Given a list of file suffixes, will generate a list of filenames
143 -- which are all unique and have the given suffixes. On exit from this
144 -- action, all those files will be removed (unless keepFiles is active)
145 makeTest :: [String] -> ([String] -> TestMonad a) -> TestMonad a
146 makeTest fileSuffixes fn = do
147 c <- testIncCount
148 fileBase <- testGetBaseName
149 keepFiles <- testKeepFiles
150 let files = zipWith (++) (repeat (fileBase ++ show c)) fileSuffixes
151 testFinally (fn files)
152 (when (not keepFiles)
153 (mapM_ removeOrIgnore files))
154 where
155 removeOrIgnore f = liftTestIO (catchIO (removeFile f) (const $ return ()))
156 -- Convert from lists to tuples (to avoid "incomplete pattern" warnings in the callers)
157 makeTest2 :: (String,String) -> ((String,String) -> TestMonad a) -> TestMonad a
158 makeTest2 (a,b) fn = makeTest [a,b] helper
159 where helper [a',b'] = fn (a',b')
160 helper _ = error "makeTest: internal error"
161 makeTest3 :: (String,String,String) -> ((String,String,String) -> TestMonad a) -> TestMonad a
162 makeTest3 (a,b,c) fn = makeTest [a,b,c] helper
163 where helper [a',b',c'] = fn (a',b',c')
164 helper _ = error "makeTest: internal error"
165
166 -- A Zipper over lists. Unlike ListZipper, this separates at the type level
167 -- a list which may have a currently focused item (Zipper a) from
168 -- a list which _definitely_ has a focused item (ZCursor a), so
169 -- that zNext can be total.
170 data Zipper a = End { zEnd :: S.Seq a }
171 | Zipper (ZCursor a)
172
173 data ZCursor a = ZCursor { zCursor :: a,
174 zAbove :: S.Seq a, -- elements prior to the cursor
175 -- in regular order (not reversed!)
176 zBelow :: S.Seq a -- elements after the cursor
177 }
178
179 zipFromList :: [a] -> Zipper a
180 zipFromList [] = End S.empty
181 zipFromList (l:ls) = Zipper (ZCursor l S.empty (S.fromList ls))
182
183 zNext :: ZCursor a -> Zipper a
184 zNext (ZCursor c above below) =
185 case S.viewl below of
186 S.EmptyL -> End (above |> c)
187 c' :< below' -> Zipper (ZCursor c' (above |> c) below')
188
189 -- Generates the .hs file from the .hsc file, by looping over each
190 -- Special element and calling outputSpecial to find out what it needs.
191 diagnose :: String -> (String -> TestMonad ()) -> [Token] -> TestMonad ()
192 diagnose inputFilename output input = do
193 checkValidity input
194 output ("{-# LINE 1 \"" ++ inputFilename ++ "\" #-}\n")
195 loop (zipFromList input)
196
197 where
198 loop (End _) = return ()
199 loop (Zipper z@ZCursor {zCursor=Special _ key _}) =
200 case key of
201 _ | key `elem` ["if","ifdef","ifndef","elif","else"] -> do
202 condHolds <- checkConditional z
203 if condHolds
204 then loop (zNext z)
205 else loop =<< (either testFail' return (skipFalseConditional (zNext z)))
206 "endif" -> loop (zNext z)
207 _ -> do
208 outputSpecial output z
209 loop (zNext z)
210 loop (Zipper z@ZCursor {zCursor=Text pos txt}) = do
211 outputText output pos txt
212 loop (zNext z)
213
214 outputSpecial :: (String -> TestMonad ()) -> ZCursor Token -> TestMonad ()
215 outputSpecial output (z@ZCursor {zCursor=Special pos@(SourcePos file line) key value}) =
216 case key of
217 "const" -> outputConst value show
218 "offset" -> outputConst ("offsetof(" ++ value ++ ")") (\i -> "(" ++ show i ++ ")")
219 "size" -> outputConst ("sizeof(" ++ value ++ ")") (\i -> "(" ++ show i ++ ")")
220 "alignment" -> outputConst (alignment value)
221 (\i -> "(" ++ show i ++ ")")
222 "peek" -> outputConst ("offsetof(" ++ value ++ ")")
223 (\i -> "(\\hsc_ptr -> peekByteOff hsc_ptr " ++ show i ++ ")")
224 "poke" -> outputConst ("offsetof(" ++ value ++ ")")
225 (\i -> "(\\hsc_ptr -> pokeByteOff hsc_ptr " ++ show i ++ ")")
226 "ptr" -> outputConst ("offsetof(" ++ value ++ ")")
227 (\i -> "(\\hsc_ptr -> hsc_ptr `plusPtr` " ++ show i ++ ")")
228 "type" -> computeType z >>= output
229 "enum" -> computeEnum z >>= output
230 "error" -> testFail pos ("#error " ++ value)
231 "warning" -> liftTestIO $ putStrLn (file ++ ":" ++ show line ++ " warning: " ++ value)
232 "include" -> return ()
233 "define" -> return ()
234 "undef" -> return ()
235 _ -> testFail pos ("directive " ++ key ++ " cannot be handled in cross-compilation mode")
236 where outputConst value' formatter = computeConst z value' >>= (output . formatter)
237 outputSpecial _ _ = error "outputSpecial's argument isn't a Special"
238
239 outputText :: (String -> TestMonad ()) -> SourcePos -> String -> TestMonad ()
240 outputText output (SourcePos file line) txt =
241 case break (=='\n') txt of
242 (noNewlines, []) -> output noNewlines
243 (firstLine, _:restOfLines) ->
244 output (firstLine ++ "\n" ++
245 "{-# LINE " ++ show (line+1) ++ " \"" ++ file ++ "\" #-}\n" ++
246 restOfLines)
247
248 -- Bleh, messy. For each test we're compiling, we have a specific line of
249 -- code that may cause compiler errors -- that's the test we want to perform.
250 -- However, we *really* don't want any other kinds of compiler errors sneaking
251 -- in (which might be e.g. due to the user's syntax errors) or we'll make the
252 -- wrong conclusions on our tests.
253 --
254 -- So before we compile any of the tests, take a pass over the whole file and
255 -- generate a .c file which should fail if there are any syntax errors in what
256 -- the user gaves us. Hopefully, then the only reason our later compilations
257 -- might fail is the particular reason we want.
258 --
259 -- Another approach would be to try to parse the stdout of GCC and diagnose
260 -- whether the error is the one we want. That's tricky because of localization
261 -- etc. etc., though it would be less nerve-wracking. FYI it's not the approach
262 -- that autoconf went with.
263 checkValidity :: [Token] -> TestMonad ()
264 checkValidity input = do
265 config <- testGetConfig
266 flags <- testGetFlags
267 let test = outTemplateHeaderCProg (cTemplate config) ++
268 concatMap outFlagHeaderCProg flags ++
269 concatMap (uncurry outValidityCheck) (zip input [0..])
270 testLog ("checking for compilation errors") $ do
271 success <- makeTest2 (".c",".o") $ \(cFile,oFile) -> do
272 liftTestIO $ writeBinaryFile cFile test
273 compiler <- testGetCompiler
274 runCompiler compiler
275 (["-c",cFile,"-o",oFile]++[f | CompFlag f <- flags])
276 Nothing
277 when (not success) $ testFail' "compilation failed"
278 testLog' "compilation is error-free"
279
280 outValidityCheck :: Token -> Int -> String
281 outValidityCheck s@(Special pos key value) uniq =
282 case key of
283 "const" -> checkValidConst value
284 "offset" -> checkValidConst ("offsetof(" ++ value ++ ")")
285 "size" -> checkValidConst ("sizeof(" ++ value ++ ")")
286 "alignment" -> checkValidConst (alignment value)
287 "peek" -> checkValidConst ("offsetof(" ++ value ++ ")")
288 "poke" -> checkValidConst ("offsetof(" ++ value ++ ")")
289 "ptr" -> checkValidConst ("offsetof(" ++ value ++ ")")
290 "type" -> checkValidType
291 "enum" -> checkValidEnum
292 _ -> outHeaderCProg' s
293 where
294 checkValidConst value' = "void _hsc2hs_test" ++ show uniq ++ "()\n{\n" ++ validConstTest value' ++ "}\n";
295 checkValidType = "void _hsc2hs_test" ++ show uniq ++ "()\n{\n" ++ outCLine pos ++ " (void)(" ++ value ++ ")1;\n}\n";
296 checkValidEnum =
297 case parseEnum value of
298 Nothing -> ""
299 Just (_,_,enums) ->
300 "void _hsc2hs_test" ++ show uniq ++ "()\n{\n" ++
301 concatMap (\(_,cName) -> validConstTest cName) enums ++
302 "}\n"
303
304 -- we want this to fail if the value is syntactically invalid or isn't a constant
305 validConstTest value' = outCLine pos ++ " {\n static int test_array[(" ++ value' ++ ") > 0 ? 2 : 1];\n (void)test_array;\n }\n";
306
307 outValidityCheck (Text _ _) _ = ""
308
309 -- Skips over some #if or other conditional that we found to be false.
310 -- I.e. the argument should be a zipper whose cursor is one past the #if,
311 -- and returns a zipper whose cursor points at the next item which
312 -- could possibly be compiled.
313 skipFalseConditional :: Zipper Token -> Either String (Zipper Token)
314 skipFalseConditional (End _) = Left "unterminated endif"
315 skipFalseConditional (Zipper z@(ZCursor {zCursor=Special _ key _})) =
316 case key of
317 "if" -> either Left skipFalseConditional $ skipFullConditional 0 (zNext z)
318 "ifdef" -> either Left skipFalseConditional $ skipFullConditional 0 (zNext z)
319 "ifndef" -> either Left skipFalseConditional $ skipFullConditional 0 (zNext z)
320 "elif" -> Right $ Zipper z
321 "else" -> Right $ Zipper z
322 "endif" -> Right $ zNext z
323 _ -> skipFalseConditional (zNext z)
324 skipFalseConditional (Zipper z) = skipFalseConditional (zNext z)
325
326 -- Skips over an #if all the way to the #endif
327 skipFullConditional :: Int -> Zipper Token -> Either String (Zipper Token)
328 skipFullConditional _ (End _) = Left "unterminated endif"
329 skipFullConditional nest (Zipper z@(ZCursor {zCursor=Special _ key _})) =
330 case key of
331 "if" -> skipFullConditional (nest+1) (zNext z)
332 "ifdef" -> skipFullConditional (nest+1) (zNext z)
333 "ifndef" -> skipFullConditional (nest+1) (zNext z)
334 "endif" | nest > 0 -> skipFullConditional (nest-1) (zNext z)
335 "endif" | otherwise -> Right $ zNext z
336 _ -> skipFullConditional nest (zNext z)
337 skipFullConditional nest (Zipper z) = skipFullConditional nest (zNext z)
338
339 data IntegerConstant = Signed Integer |
340 Unsigned Integer deriving (Show)
341 -- Prints an syntatically valid integer in C
342 cShowInteger :: IntegerConstant -> String
343 cShowInteger (Signed x) | x < 0 = "(" ++ show (x+1) ++ "-1)"
344 -- Trick to avoid overflowing large integer constants
345 -- http://www.hardtoc.com/archives/119
346 cShowInteger (Signed x) = show x
347 cShowInteger (Unsigned x) = show x ++ "u"
348
349 data IntegerComparison = GreaterOrEqual IntegerConstant |
350 LessOrEqual IntegerConstant
351 instance Show IntegerComparison where
352 showsPrec _ (GreaterOrEqual c) = showString "`GreaterOrEqual` " . shows c
353 showsPrec _ (LessOrEqual c) = showString "`LessOrEqual` " . shows c
354
355 cShowCmpTest :: IntegerComparison -> String
356 cShowCmpTest (GreaterOrEqual x) = ">=" ++ cShowInteger x
357 cShowCmpTest (LessOrEqual x) = "<=" ++ cShowInteger x
358
359 -- The cursor should point at #{const SOME_VALUE} or something like that.
360 -- Determines the value of SOME_VALUE using binary search; this
361 -- is a trick which is cribbed from autoconf's AC_COMPUTE_INT.
362 computeConst :: ZCursor Token -> String -> TestMonad Integer
363 computeConst zOrig@(ZCursor (Special pos _ _) _ _) value = do
364 testLogAtPos pos ("computing " ++ value) $ do
365 nonNegative <- compareConst z (GreaterOrEqual (Signed 0))
366 integral <- checkValueIsIntegral z nonNegative
367 when (not integral) $ testFail pos $ value ++ " is not an integer"
368 (lower,upper) <- bracketBounds z nonNegative
369 int <- binarySearch z nonNegative lower upper
370 testLog' $ "result: " ++ show int
371 return int
372 where -- replace the Special's value with the provided value; e.g. the special
373 -- is #{size SOMETHING} and we might replace value with "sizeof(SOMETHING)".
374 z = zOrig {zCursor=specialSetValue value (zCursor zOrig)}
375 specialSetValue v (Special p k _) = Special p k v
376 specialSetValue _ _ = error "computeConst argument isn't a Special"
377 computeConst _ _ = error "computeConst argument isn't a Special"
378
379 -- Binary search, once we've bracketed the integer.
380 binarySearch :: ZCursor Token -> Bool -> Integer -> Integer -> TestMonad Integer
381 binarySearch _ _ l u | l == u = return l
382 binarySearch z nonNegative l u = do
383 let mid :: Integer
384 mid = (l+u+1) `div` 2
385 inTopHalf <- compareConst z (GreaterOrEqual $ (if nonNegative then Unsigned else Signed) mid)
386 let (l',u') = if inTopHalf then (mid,u) else (l,(mid-1))
387 assert (l < mid && mid <= u && -- l < mid <= u
388 l <= l' && l' <= u' && u' <= u && -- l <= l' <= u' <= u
389 u'-l' < u-l) -- |u' - l'| < |u - l|
390 (binarySearch z nonNegative l' u')
391
392 -- Establishes bounds on the unknown integer. By searching increasingly
393 -- large powers of 2, it'll bracket an integer x by lower & upper
394 -- such that lower <= x <= upper.
395 --
396 -- Assumes 2's complement integers.
397 bracketBounds :: ZCursor Token -> Bool -> TestMonad (Integer, Integer)
398 bracketBounds z nonNegative = do
399 let -- test against integers 2**x-1 when positive, and 2**x when negative,
400 -- to avoid generating constants that'd overflow the machine's integers.
401 -- I.e. suppose we're searching for #{const INT_MAX} (e.g. 2^32-1).
402 -- If we're comparing against all 2**x-1, we'll stop our search
403 -- before we ever overflow int.
404 powersOfTwo = iterate (\a -> 2*a) 1
405 positiveBounds = map pred powersOfTwo
406 negativeBounds = map negate powersOfTwo
407
408 -- Test each element of the bounds list until we find one that exceeds
409 -- the integer.
410 loop cmp inner (maybeOuter:bounds') = do
411 outerBounded <- compareConst z (cmp maybeOuter)
412 if outerBounded
413 then return (inner,maybeOuter)
414 else loop cmp maybeOuter bounds'
415 loop _ _ _ = error "bracketBounds: infinite list exhausted"
416
417 if nonNegative
418 then do (inner,outer) <- loop (LessOrEqual . Unsigned) (-1) positiveBounds
419 return (inner+1,outer)
420 else do (inner,outer) <- loop (GreaterOrEqual . Signed) 0 negativeBounds
421 return (outer,inner-1)
422
423 -- For #{enum} codegen; mimics template-hsc.h's hsc_haskellize
424 haskellize :: String -> String
425 haskellize [] = []
426 haskellize (firstLetter:next) = toLower firstLetter : loop False next
427 where loop _ [] = []
428 loop _ ('_':as) = loop True as
429 loop upper (a:as) = (if upper then toUpper a else toLower a) : loop False as
430
431 -- For #{enum} codegen; in normal hsc2hs, any whitespace in the enum types &
432 -- constructors will be mangled by the C preprocessor. This mimics the same
433 -- mangling.
434 stringify :: String -> String
435 -- Spec: stringify = unwords . words
436 stringify = go False . dropWhile isSpace
437 where
438 go _haveSpace [] = []
439 go haveSpace (x:xs)
440 | isSpace x = go True xs
441 | otherwise = if haveSpace
442 then ' ' : x : go False xs
443 else x : go False xs
444
445 -- For #{alignment} codegen; mimic's template-hsc.h's hsc_alignment
446 alignment :: String -> String
447 alignment t = "offsetof(struct {char x__; " ++ t ++ " (y__); }, y__)"
448
449 computeEnum :: ZCursor Token -> TestMonad String
450 computeEnum z@(ZCursor (Special _ _ enumText) _ _) =
451 case parseEnum enumText of
452 Nothing -> return ""
453 Just (enumType,constructor,enums) ->
454 concatM enums $ \(maybeHsName, cName) -> do
455 constValue <- computeConst z cName
456 let hsName = fromMaybe (haskellize cName) maybeHsName
457 return $
458 hsName ++ " :: " ++ stringify enumType ++ "\n" ++
459 hsName ++ " = " ++ stringify constructor ++ " " ++ showsPrec 11 constValue "\n"
460 where concatM l = liftM concat . forM l
461 computeEnum _ = error "computeEnum argument isn't a Special"
462
463 -- Implementation of #{type}, using computeConst
464 computeType :: ZCursor Token -> TestMonad String
465 computeType z@(ZCursor (Special pos _ value) _ _) = do
466 testLogAtPos pos ("computing type of " ++ value) $ do
467 integral <- testLog ("checking if type " ++ value ++ " is an integer") $ do
468 success <- runCompileBooleanTest z $ "(" ++ value ++ ")(int)(" ++ value ++ ")1.4 == (" ++ value ++ ")1.4"
469 testLog' $ "result: " ++ (if success then "integer" else "floating")
470 return success
471 typeRet <- if integral
472 then do
473 signed <- testLog ("checking if type " ++ value ++ " is signed") $ do
474 success <- runCompileBooleanTest z $ "(" ++ value ++ ")(-1) < (" ++ value ++ ")0"
475 testLog' $ "result: " ++ (if success then "signed" else "unsigned")
476 return success
477 size <- computeConst z ("sizeof(" ++ value ++ ")")
478 return $ (if signed then "Int" else "Word") ++ (show (size * 8))
479 else do
480 let checkSize test = testLog ("checking if " ++ test) $ do
481 success <- runCompileBooleanTest z test
482 testLog' $ "result: " ++ show success
483 return success
484 ldouble <- checkSize ("sizeof(" ++ value ++ ") > sizeof(double)")
485 if ldouble
486 then return "LDouble"
487 else do
488 double <- checkSize ("sizeof(" ++ value ++ ") == sizeof(double)")
489 if double
490 then return "Double"
491 else return "Float"
492 testLog' $ "result: " ++ typeRet
493 return typeRet
494 computeType _ = error "computeType argument isn't a Special"
495
496 outHeaderCProg' :: Token -> String
497 outHeaderCProg' (Special pos key value) = outHeaderCProg (pos,key,value)
498 outHeaderCProg' _ = ""
499
500 -- Checks if an #if/#ifdef etc. etc. is true by inserting a #error
501 -- and seeing if the compile fails.
502 checkConditional :: ZCursor Token -> TestMonad Bool
503 checkConditional (ZCursor s@(Special pos key value) above below) = do
504 config <- testGetConfig
505 flags <- testGetFlags
506 let test = outTemplateHeaderCProg (cTemplate config) ++
507 (concatMap outFlagHeaderCProg flags) ++
508 (concatMap outHeaderCProg' above) ++
509 outHeaderCProg' s ++ "#error T\n" ++
510 (concatMap outHeaderCProg' below)
511 testLogAtPos pos ("checking #" ++ key ++ " " ++ value) $ do
512 condTrue <- not `fmap` runCompileTest test
513 testLog' $ "result: " ++ show condTrue
514 return condTrue
515 checkConditional _ = error "checkConditional argument isn't a Special"
516
517 -- Make sure the value we're trying to binary search isn't floating point.
518 checkValueIsIntegral :: ZCursor Token -> Bool -> TestMonad Bool
519 checkValueIsIntegral z@(ZCursor (Special _ _ value) _ _) nonNegative = do
520 let intType = if nonNegative then "unsigned long long" else "long long"
521 testLog ("checking if " ++ value ++ " is an integer") $ do
522 success <- runCompileBooleanTest z $ "(" ++ intType ++ ")(" ++ value ++ ") == (" ++ value ++ ")"
523 testLog' $ "result: " ++ (if success then "integer" else "floating")
524 return success
525 checkValueIsIntegral _ _ = error "checkConditional argument isn't a Special"
526
527 compareConst :: ZCursor Token -> IntegerComparison -> TestMonad Bool
528 compareConst z@(ZCursor (Special _ _ value) _ _) cmpTest = do
529 testLog ("checking " ++ value ++ " " ++ show cmpTest) $ do
530 success <- runCompileBooleanTest z $ "(" ++ value ++ ") " ++ cShowCmpTest cmpTest
531 testLog' $ "result: " ++ show success
532 return success
533 compareConst _ _ = error "compareConst argument isn't a Special"
534
535 -- Given a compile-time constant with boolean type, this extracts the
536 -- value of the constant by compiling a .c file only.
537 --
538 -- The trick comes from autoconf: use the fact that the compiler must
539 -- perform constant arithmetic for computation of array dimensions, and
540 -- will generate an error if the array has negative size.
541 runCompileBooleanTest :: ZCursor Token -> String -> TestMonad Bool
542 runCompileBooleanTest (ZCursor s above below) booleanTest = do
543 config <- testGetConfig
544 flags <- testGetFlags
545 let test = -- all the surrounding code
546 outTemplateHeaderCProg (cTemplate config) ++
547 (concatMap outFlagHeaderCProg flags) ++
548 (concatMap outHeaderCProg' above) ++
549 outHeaderCProg' s ++
550 -- the test
551 "int _hsc2hs_test() {\n" ++
552 " static int test_array[1 - 2 * !(" ++ booleanTest ++ ")];\n" ++
553 " return test_array[0];\n" ++
554 "}\n" ++
555 (concatMap outHeaderCProg' below)
556 runCompileTest test
557
558 runCompileTest :: String -> TestMonad Bool
559 runCompileTest testStr = do
560 makeTest3 (".c", ".o",".txt") $ \(cFile,oFile,stdout) -> do
561 liftTestIO $ writeBinaryFile cFile testStr
562 flags <- testGetFlags
563 compiler <- testGetCompiler
564 runCompiler compiler
565 (["-c",cFile,"-o",oFile]++[f | CompFlag f <- flags])
566 (Just stdout)
567
568 runCompiler :: FilePath -> [String] -> Maybe FilePath -> TestMonad Bool
569 runCompiler prog args mStdoutFile = do
570 let cmdLine = showCommandForUser prog args
571 testLog ("executing: " ++ cmdLine) $ liftTestIO $ do
572 mHOut <- case mStdoutFile of
573 Nothing -> return Nothing
574 Just stdoutFile -> liftM Just $ openFile stdoutFile WriteMode
575 process <- runProcess prog args Nothing Nothing Nothing mHOut mHOut
576 case mHOut of
577 Just hOut -> hClose hOut
578 Nothing -> return ()
579 exitStatus <- waitForProcess process
580 return $ case exitStatus of
581 ExitSuccess -> True
582 ExitFailure _ -> False
583
584 -- The main driver for cross-compilation mode
585 outputCross :: Config -> String -> String -> String -> String -> [Token] -> IO ()
586 outputCross config outName outDir outBase inName toks =
587 runTestMonad $ do
588 file <- liftTestIO $ openFile outName WriteMode
589 (diagnose inName (liftTestIO . hPutStr file) toks
590 `testFinally` (liftTestIO $ hClose file))
591 `testOnException` (liftTestIO $ removeFile outName) -- cleanup on errors
592 where
593 tmenv = TestMonadEnv (cVerbose config) 0 (cKeepFiles config) (outDir++outBase++"_hsc_test") (cFlags config) config (cCompiler config)
594 runTestMonad x = runTest x tmenv 0 >>= (handleError . fst)
595
596 handleError (Left e) = die (e++"\n")
597 handleError (Right ()) = return ()