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
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
{- Allows linking haskell programs too big for all the files to fit in a
- command line.
-
- See https://ghc.haskell.org/trac/ghc/ticket/8596
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Main where
import Data.Maybe
import Data.Either
import Data.List
import Data.List.Utils
import Text.Parsec
import Text.Parsec.String
import Control.Applicative ((<$>))
import Control.Monad
import Utility.Monad
import Utility.Process
import System.Directory
data CmdParams = CmdParams
{ cmd :: String
, opts :: String
, env :: Maybe [(String, String)]
} deriving (Show)
{- Find where ghc calls gcc to link the executable. -}
parseGhcLink :: Parser CmdParams
parseGhcLink = do
many prelinkline
linkheaderline
char '"'
gcccmd <- many1 (noneOf "\"")
string "\" "
gccparams <- restOfLine
return $ CmdParams gcccmd (manglepaths gccparams) Nothing
where
linkheaderline = do
string "*** Linker"
restOfLine
prelinkline = do
notFollowedBy linkheaderline
restOfLine
manglepaths = replace "\\" "/"
{- Find where gcc calls collect2. -}
parseGccLink :: Parser CmdParams
parseGccLink = do
many preenv
env <- collectenv
try $ char ' '
path <- manyTill anyChar (try $ string collectcmd)
char ' '
collect2params <- restOfLine
return $ CmdParams (path ++ collectcmd) (escapeDosPaths collect2params) env
where
collectcmd = "collect2.exe"
pathenv = "COMPILER_PATH"
libpathenv = "LIBRARY_PATH"
optenv = "COLLECT_GCC_OPTIONS"
collectenv = do
string pathenv
char '='
p <- restOfLine
string libpathenv
char '='
lp <- restOfLine
string optenv
char '='
o <- restOfLine
return $ Just [(pathenv, p), (libpathenv, lp), (optenv, o)]
preenv = do
notFollowedBy collectenv
restOfLine
{- Find where collect2 calls ld. -}
parseCollect2 :: Parser CmdParams
parseCollect2 = do
manyTill restOfLine (try versionline)
path <- manyTill anyChar (try $ string ldcmd)
char ' '
params <- restOfLine
return $ CmdParams (path ++ ldcmd) (escapeDosPaths params) Nothing
where
ldcmd = "ld.exe"
versionline = do
string "collect2 version"
restOfLine
{- Input contains something like
- c:/program files/haskell platform/foo -LC:/Program Files/Haskell Platform/ -L...
- and the *right* spaces must be escaped with \
-
- Argh.
-}
escapeDosPaths :: String -> String
escapeDosPaths = replace "Program Files" "Program\\ Files"
. replace "program files" "program\\ files"
. replace "Haskell Platform" "Haskell\\ Platform"
. replace "haskell platform" "haskell\\ platform"
. replace "Application Data" "Application\\ Data"
. replace "Files (x86)" "Files\\ (x86)"
. replace "files (x86)" "files\\ (x86)"
restOfLine :: Parser String
restOfLine = newline `after` many (noneOf "\n")
getOutput :: String -> [String] -> Maybe [(String, String)] -> IO (String, Bool)
getOutput cmd params env = do
putStrLn $ unwords [cmd, show params]
processTranscript' cmd params env Nothing
runParser' :: Parser a -> String -> a
runParser' p s = either failedparse id (parse p "" s)
where
failedparse e = error $ (show e) ++ "\n<<<\n" ++ s ++ "\n>>>"
atFile :: FilePath -> String
atFile f = '@':f
runAtFile :: Parser CmdParams -> String -> FilePath -> [String] -> IO (String, Bool)
runAtFile p s f extraparams = do
writeFile f (opts c)
out <- getOutput (cmd c) (atFile f:extraparams) (env c)
removeFile f
return out
where
c = runParser' p s
main = do
ghcout <- fst <$> getOutput "cabal"
["build", "-v2", "--ghc-options=-v -keep-tmp-files"] Nothing
gccout <- fst <$> runAtFile parseGhcLink ghcout "gcc.opt" ["-v"]
collect2out <- fst <$> runAtFile parseGccLink gccout "collect2.opt" ["-v"]
(out, ok) <- runAtFile parseCollect2 collect2out "ld.opt" []
unless ok $
error $ "ld failed:\n" ++ out
|
