Use FilePath to make paths when building GHC/Prim.hs and GHC/PrimopWrappers.hs
[packages/random.git] / Setup.hs
1
2 {-
3 We need to do some ugly hacks here as base mix of portable and
4 unportable stuff, as well as home to some GHC magic.
5 -}
6
7 module Main (main) where
8
9 import Control.Monad
10 import Data.List
11 import Distribution.PackageDescription
12 import Distribution.Setup
13 import Distribution.Simple
14 import Distribution.Simple.LocalBuildInfo
15 import Distribution.Simple.Utils
16 import System.Cmd
17 import System.Environment
18 import System.FilePath
19 import System.Info
20
21 main :: IO ()
22 main = do args <- getArgs
23 let (ghcArgs, args') = extractGhcArgs args
24 (confArgs, args'') = extractConfigureArgs args'
25 hooks = defaultUserHooks {
26 confHook = add_extra_deps
27 $ confHook defaultUserHooks,
28 postConf = add_configure_options confArgs
29 $ postConf defaultUserHooks,
30 buildHook = build_primitive_sources
31 $ add_ghc_options ghcArgs
32 $ filter_modules_hook
33 $ buildHook defaultUserHooks,
34 makefileHook = add_ghc_options ghcArgs
35 $ filter_modules_hook
36 $ makefileHook defaultUserHooks,
37 regHook = add_extra_libs
38 $ regHook defaultUserHooks,
39 instHook = filter_modules_hook
40 $ instHook defaultUserHooks }
41 withArgs args'' $ defaultMainWithHooks hooks
42
43 extractGhcArgs :: [String] -> ([String], [String])
44 extractGhcArgs = extractPrefixArgs "--ghc-option="
45
46 extractConfigureArgs :: [String] -> ([String], [String])
47 extractConfigureArgs = extractPrefixArgs "--configure-option="
48
49 extractPrefixArgs :: String -> [String] -> ([String], [String])
50 extractPrefixArgs the_prefix args
51 = let f [] = ([], [])
52 f (x:xs) = case f xs of
53 (wantedArgs, otherArgs) ->
54 case removePrefix the_prefix x of
55 Just wantedArg ->
56 (wantedArg:wantedArgs, otherArgs)
57 Nothing ->
58 (wantedArgs, x:otherArgs)
59 in f args
60
61 removePrefix :: String -> String -> Maybe String
62 removePrefix "" ys = Just ys
63 removePrefix _ "" = Nothing
64 removePrefix (x:xs) (y:ys)
65 | x == y = removePrefix xs ys
66 | otherwise = Nothing
67
68 type Hook a = PackageDescription -> LocalBuildInfo -> UserHooks -> a -> IO ()
69 type ConfHook = PackageDescription -> ConfigFlags -> IO LocalBuildInfo
70 type PostConfHook = Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo
71 -> IO ()
72
73 -- type PDHook = PackageDescription -> ConfigFlags -> IO ()
74
75 build_primitive_sources :: Hook a -> Hook a
76 build_primitive_sources f pd lbi uhs x
77 = do when (compilerFlavor (compiler lbi) == GHC) $ do
78 let genprimopcode = joinPath ["..", "..", "utils",
79 "genprimopcode", "genprimopcode"]
80 primops = joinPath ["..", "..", "compiler", "prelude",
81 "primops.txt"]
82 primhs = joinPath ["GHC", "Prim.hs"]
83 primopwrappers = joinPath ["GHC", "PrimopWrappers.hs"]
84 maybeExit $ system (genprimopcode ++ " --make-haskell-source < "
85 ++ primops ++ " > " ++ primhs)
86 maybeExit $ system (genprimopcode ++ " --make-haskell-wrappers < "
87 ++ primops ++ " > " ++ primopwrappers)
88 f pd lbi uhs x
89
90 add_ghc_options :: [String] -> Hook a -> Hook a
91 add_ghc_options args f pd lbi uhs x
92 = do let lib' = case library pd of
93 Just lib ->
94 let bi = libBuildInfo lib
95 opts = options bi ++ [(GHC, args)]
96 bi' = bi { options = opts }
97 in lib { libBuildInfo = bi' }
98 Nothing -> error "Expected a library"
99 pd' = pd { library = Just lib' }
100 f pd' lbi uhs x
101
102 add_configure_options :: [String] -> PostConfHook -> PostConfHook
103 add_configure_options args f as cfs pd lbi
104 = f (as ++ args) cfs pd lbi
105
106 filter_modules_hook :: Hook a -> Hook a
107 filter_modules_hook f pd lbi uhs x
108 = let build_filter = case compilerFlavor $ compiler lbi of
109 GHC -> forGHCBuild
110 _ -> isPortableBuild
111 lib' = case library pd of
112 Just lib ->
113 let ems = filter build_filter (exposedModules lib)
114 in lib { exposedModules = ems }
115 Nothing -> error "Expected a library"
116 pd' = pd { library = Just lib' }
117 in f pd' lbi uhs x
118
119 isPortableBuild :: String -> Bool
120 isPortableBuild s
121 | "GHC" `isPrefixOf` s = False
122 | "Data.Generics" `isPrefixOf` s = False
123 | otherwise = s `notElem` ["Foreign.Concurrent", "System.Process"]
124
125 forGHCBuild :: String -> Bool
126 forGHCBuild = ("GHC.Prim" /=)
127
128 add_extra_deps :: ConfHook -> ConfHook
129 add_extra_deps f pd cf
130 = do lbi <- f pd cf
131 case compilerFlavor (compiler lbi) of
132 GHC ->
133 do -- Euch. We should just add the right thing to the lbi
134 -- ourselves rather than rerunning configure.
135 let pd' = pd { buildDepends = Dependency "rts" AnyVersion
136 : buildDepends pd }
137 f pd' cf
138 _ ->
139 return lbi
140
141 add_extra_libs :: Hook a -> Hook a
142 add_extra_libs f pd lbi uhs x
143 = let pd' = if (os == "mingw32") && (compilerFlavor (compiler lbi) == GHC)
144 then case library pd of
145 Just lib ->
146 let lib_bi = libBuildInfo lib
147 lib_bi' = lib_bi { extraLibs = "wsock32"
148 : "msvcrt"
149 : "kernel32"
150 : "user32"
151 : "shell32"
152 : extraLibs lib_bi }
153 lib' = lib { libBuildInfo = lib_bi' }
154 in pd { library = Just lib' }
155 Nothing -> error "Expected a library"
156 else pd
157 in f pd' lbi uhs x
158