ghc-config.hs 2.81 KB
Newer Older
1 2
import System.Environment
import System.Process
Simon Marlow's avatar
Simon Marlow committed
3
import Data.Maybe
4 5 6 7 8 9

main = do
  [ghc] <- getArgs

  info <- readProcess ghc ["+RTS", "--info"] ""
  let fields = read info :: [(String,String)]
10 11 12 13 14
  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"
15 16 17

  info <- readProcess ghc ["--info"] ""
  let fields = read info :: [(String,String)]
Simon Marlow's avatar
Simon Marlow committed
18

19
  getGhcFieldOrFail fields "GhcStage" "Stage"
20
  getGhcFieldOrFail fields "GhcDebugged" "Debug on"
21 22 23 24 25 26
  getGhcFieldOrFail fields "GhcWithNativeCodeGen" "Have native code generator"
  getGhcFieldOrFail fields "GhcWithInterpreter" "Have interpreter"
  getGhcFieldOrFail fields "GhcUnregisterised" "Unregisterised"
  getGhcFieldOrFail fields "GhcWithSMP" "Support SMP"
  getGhcFieldOrFail fields "GhcRTSWays" "RTS ways"
  getGhcFieldOrDefault fields "GhcDynamicByDefault" "Dynamic by default" "NO"
ian@well-typed.com's avatar
ian@well-typed.com committed
27
  getGhcFieldOrDefault fields "GhcDynamic" "GHC Dynamic" "NO"
28
  getGhcFieldProgWithDefault fields "AR" "ar command" "ar"
29
  getGhcFieldProgWithDefault fields "LLC" "LLVM llc command" "llc"
30

31 32 33 34 35 36 37
  let pkgdb_flag = case lookup "Project version" fields of
        Just v
          | parseVersion v >= [7,5] -> "package-db"
        _ -> "package-conf"
  putStrLn $ "GhcPackageDbFlag" ++ '=':pkgdb_flag


38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57
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)
58

59 60 61 62 63 64
getGhcField
   :: [(String,String)] -> String -> String
   -> (String -> String)
   -> IO ()
   -> IO ()
getGhcField fields mkvar key fix on_fail =
65
   case lookup key fields of
66 67
      Nothing  -> on_fail
      Just val -> putStrLn (mkvar ++ '=' : fix val)
Simon Marlow's avatar
Simon Marlow committed
68 69 70 71 72

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
73 74 75 76 77 78

fixSlashes :: FilePath -> FilePath
fixSlashes = map f
    where f '\\' = '/'
          f c    = c

79 80 81 82 83 84
parseVersion :: String -> [Int]
parseVersion v = case break (== '.') v of
  (n, rest) -> read n : case rest of
    [] -> []
    ('.':v') -> parseVersion v'
    _ -> error "bug in parseVersion"