ghc-dup: 5ab49eb1ce96e29842bd3fa3e08b2450d7941f34

     1: import System.Environment
     2: import System.Process
     3: import Data.Maybe
     4: 
     5: main = do
     6:   [ghc] <- getArgs
     7: 
     8:   info <- readProcess ghc ["+RTS", "--info"] ""
     9:   let fields = read info :: [(String,String)]
    10:   getGhcField fields "HostOS" "Host OS"
    11:   getGhcField fields "WORDSIZE" "Word size"
    12:   getGhcField fields "TARGETPLATFORM" "Target platform"
    13:   getGhcField fields "TargetOS_CPP" "Target OS"
    14:   getGhcField fields "TargetARCH_CPP" "Target architecture"
    15: 
    16:   info <- readProcess ghc ["--info"] ""
    17:   let fields = read info :: [(String,String)]
    18: 
    19:   getGhcField fields "GhcStage" "Stage"
    20:   getGhcField fields "GhcWithNativeCodeGen" "Have native code generator"
    21:   getGhcField fields "GhcWithInterpreter" "Have interpreter"
    22:   getGhcField fields "GhcUnregisterised" "Unregisterised"
    23:   getGhcField fields "GhcWithSMP" "Support SMP"
    24:   getGhcField fields "GhcRTSWays" "RTS ways"
    25:   getGhcFieldProgWithDefault fields "AR" "ar command" "ar"
    26: 
    27:   let pkgdb_flag = case lookup "Project version" fields of
    28:         Just v
    29:           | parseVersion v >= [7,5] -> "package-db"
    30:         _ -> "package-conf"
    31:   putStrLn $ "GhcPackageDbFlag" ++ '=':pkgdb_flag
    32: 
    33: 
    34: getGhcField :: [(String,String)] -> String -> String -> IO ()
    35: getGhcField fields mkvar key =
    36:    case lookup key fields of
    37:       Nothing  -> fail ("No field: " ++ key)
    38:       Just val -> putStrLn (mkvar ++ '=':val)
    39: 
    40: getGhcFieldProgWithDefault :: [(String,String)]
    41:                            -> String -> String -> String -> IO ()
    42: getGhcFieldProgWithDefault fields mkvar key deflt = do
    43:    case lookup key fields of
    44:       Nothing  -> putStrLn (mkvar ++ '=' : deflt)
    45:       Just val -> putStrLn (mkvar ++ '=' : fixSlashes (fixTopdir topdir val))
    46:  where
    47:   topdir = fromMaybe "" (lookup "LibDir" fields)
    48: 
    49: fixTopdir :: String -> String -> String
    50: fixTopdir t "" = ""
    51: fixTopdir t ('$':'t':'o':'p':'d':'i':'r':s) = t ++ s
    52: fixTopdir t (c:s) = c : fixTopdir t s
    53: 
    54: fixSlashes :: FilePath -> FilePath
    55: fixSlashes = map f
    56:     where f '\\' = '/'
    57:           f c    = c
    58: 
    59: parseVersion :: String -> [Int]
    60: parseVersion v = case break (== '.') v of
    61:   (n, rest) -> read n : case rest of
    62:     [] -> []
    63:     ('.':v') -> parseVersion v'
    64:     _ -> error "bug in parseVersion"