38d6fa36b661c2ba0931c7d92e95ad7f268dc6fc
[packages/dph.git] / dph-test / framework / DPH / War / Job / Compile.hs
1
2 module DPH.War.Job.Compile
3 (jobCompile)
4 where
5 import DPH.War.Result
6 import DPH.War.Job
7 import BuildBox
8 import System.FilePath
9 import System.Directory
10 import Control.Monad
11 import Data.List
12
13
14 -- | Compile a Haskell Source File
15 jobCompile :: Job -> Build [Result]
16 jobCompile (JobCompile
17 testName _wayName srcHS optionsGHC
18 buildDir mainCompOut mainCompErr
19 mainBin)
20
21 = do needs srcHS
22
23 -- The directory holding the Main.hs file.
24 let (srcDir, srcFile) = splitFileName srcHS
25
26 -- Copy the .hs files to the build directory.
27 -- This freshens them and ensures we won't conflict with other make jobs
28 -- running on the same source files, but in different ways.
29 ensureDir buildDir
30 sources <- io
31 $ liftM (filter (\f -> isSuffixOf ".hs" f))
32 $ lsFilesIn srcDir
33
34 qssystem $ "cp " ++ (intercalate " " sources) ++ " " ++ buildDir
35
36 -- The copied version of the root source file.
37 let srcCopyHS = buildDir </> srcFile
38
39 (time, (code, strOut, strErr))
40 <- runTimedCommand
41 $ systemTee False
42 ("ghc " ++ " -XCPP"
43 ++ " -XBangPatterns"
44 ++ " -XNoMonomorphismRestriction"
45 ++ " -XTypeOperators"
46 ++ " -XExistentialQuantification"
47 ++ " -XRankNTypes"
48 ++ " -XTypeFamilies"
49 ++ " -XMultiParamTypeClasses"
50 ++ " -XFlexibleInstances"
51 ++ " -XFlexibleContexts"
52 ++ " -XMagicHash"
53 ++ " -XUnboxedTuples"
54 ++ " -XTemplateHaskell"
55 ++ " -XStandaloneDeriving"
56 ++ " -Idph-prim-interface/interface"
57 ++ " -Idph-base/include"
58 ++ " -idph-test/framework"
59 ++ " -idph-lifted-base"
60 ++ " -idph-base"
61 ++ " -idph-prim-par"
62 ++ " -idph-prim-seq"
63 ++ " -idph-lifted-vseg"
64 ++ " -package ghc"
65 ++ " -Odph -fno-liberate-case"
66 ++ " -outputdir " ++ buildDir
67 ++ " --make " ++ srcCopyHS
68 ++ " -o " ++ mainBin)
69 ""
70
71 atomicWriteFile mainCompOut strOut
72 atomicWriteFile mainCompErr strErr
73
74 let success = case code of
75 ExitFailure _ -> False
76 _ -> True
77
78 when (not success)
79 $ do io $ putStrLn strErr
80 io $ putStrLn strOut
81
82 let ftime = fromRational $ toRational time
83 return $ [ ResultAspect $ Time TotalWall `secs` ftime]
84 ++ (if success then [] else [ResultUnexpectedFailure])
85