blob: efb88f81f25f5f5b34aae17dc1a1615b56ca2ca2 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
import System.Environment
import System.Process
import Data.Maybe
main :: IO ()
main = do
[ghc] <- getArgs
info <- readProcess ghc ["+RTS", "--info"] ""
let fields = read info :: [(String,String)]
getGhcFieldOrFail fields "HostOS" "Host OS"
getGhcFieldOrFail fields "WORDSIZE" "Word size"
getGhcFieldOrFail fields "TARGETPLATFORM" "Target platform"
getGhcFieldOrFail fields "TargetOS_CPP" "Target OS"
getGhcFieldOrFail fields "TargetARCH_CPP" "Target architecture"
info <- readProcess ghc ["--info"] ""
let fields = read info :: [(String,String)]
getGhcFieldOrFail fields "GhcStage" "Stage"
getGhcFieldOrFail fields "GhcDebugged" "Debug on"
getGhcFieldOrFail fields "GhcWithNativeCodeGen" "Have native code generator"
getGhcFieldOrFail fields "GhcWithInterpreter" "Have interpreter"
getGhcFieldOrFail fields "GhcWithRtsLinker" "target has RTS linker"
getGhcFieldOrFail fields "GhcUnregisterised" "Unregisterised"
getGhcFieldOrFail fields "GhcWithSMP" "Support SMP"
getGhcFieldOrFail fields "GhcRTSWays" "RTS ways"
getGhcFieldOrFail fields "GhcLibdir" "LibDir"
getGhcFieldOrFail fields "GhcGlobalPackageDb" "Global Package DB"
getGhcFieldOrDefault fields "GhcDynamic" "GHC Dynamic" "NO"
getGhcFieldOrDefault fields "GhcProfiled" "GHC Profiled" "NO"
getGhcFieldOrDefault fields "LeadingUnderscore" "Leading underscore" "NO"
getGhcFieldProgWithDefault fields "AR" "ar command" "ar"
getGhcFieldProgWithDefault fields "CLANG" "LLVM clang command" "clang"
getGhcFieldProgWithDefault fields "LLC" "LLVM llc command" "llc"
getGhcFieldProgWithDefault fields "TEST_CC" "C compiler command" "gcc"
getGhcFieldProgWithDefault fields "TEST_CC_OPTS" "C compiler flags" ""
getGhcFieldOrFail :: [(String,String)] -> String -> String -> IO ()
getGhcFieldOrFail fields mkvar key
= getGhcField fields mkvar key id (fail ("No field: " ++ key))
getGhcFieldOrDefault :: [(String,String)] -> String -> String -> String -> IO ()
getGhcFieldOrDefault fields mkvar key deflt
= getGhcField fields mkvar key id on_fail
where
on_fail = putStrLn (mkvar ++ '=' : deflt)
getGhcFieldProgWithDefault
:: [(String,String)]
-> String -> String -> String
-> IO ()
getGhcFieldProgWithDefault fields mkvar key deflt
= getGhcField fields mkvar key fix on_fail
where
fix val = fixSlashes (fixTopdir topdir val)
topdir = fromMaybe "" (lookup "LibDir" fields)
on_fail = putStrLn (mkvar ++ '=' : deflt)
getGhcField
:: [(String,String)] -> String -> String
-> (String -> String)
-> IO ()
-> IO ()
getGhcField fields mkvar key fix on_fail =
case lookup key fields of
Nothing -> on_fail
Just val -> putStrLn (mkvar ++ '=' : fix val)
fixTopdir :: String -> String -> String
fixTopdir t "" = ""
fixTopdir t ('$':'t':'o':'p':'d':'i':'r':s) = t ++ s
fixTopdir t (c:s) = c : fixTopdir t s
fixSlashes :: FilePath -> FilePath
fixSlashes = map f
where f '\\' = '/'
f c = c
parseVersion :: String -> [Int]
parseVersion v = case break (== '.') v of
(n, rest) -> read n : case rest of
[] -> []
('.':v') -> parseVersion v'
_ -> error "bug in parseVersion"
|
