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.
7 module Main (main) where
11 import Distribution.Simple
12 import Distribution.PackageDescription
13 import Distribution.Setup
14 import Distribution.Simple.LocalBuildInfo
15 import System.Environment
19 main = do args <- getArgs
20 let (ghcArgs, args') = extractGhcArgs args
21 (confArgs, args'') = extractConfigureArgs args'
22 hooks = defaultUserHooks {
23 confHook = add_extra_deps
24 $ confHook defaultUserHooks,
25 postConf = add_configure_options confArgs
26 $ postConf defaultUserHooks,
27 buildHook = add_ghc_options ghcArgs
29 $ buildHook defaultUserHooks,
30 makefileHook = add_ghc_options ghcArgs
32 $ makefileHook defaultUserHooks,
33 regHook = add_extra_libs
34 $ regHook defaultUserHooks,
35 instHook = filter_modules_hook
36 $ instHook defaultUserHooks }
37 withArgs args'' $ defaultMainWithHooks hooks
39 extractGhcArgs :: [String] -> ([String], [String])
40 extractGhcArgs = extractPrefixArgs "--ghc-option="
42 extractConfigureArgs :: [String] -> ([String], [String])
43 extractConfigureArgs = extractPrefixArgs "--configure-option="
45 extractPrefixArgs :: String -> [String] -> ([String], [String])
46 extractPrefixArgs the_prefix args
48 f (x:xs) = case f xs of
49 (wantedArgs, otherArgs) ->
50 case removePrefix the_prefix x of
52 (wantedArg:wantedArgs, otherArgs)
54 (wantedArgs, x:otherArgs)
57 removePrefix :: String -> String -> Maybe String
58 removePrefix "" ys = Just ys
59 removePrefix _ "" = Nothing
60 removePrefix (x:xs) (y:ys)
61 | x == y = removePrefix xs ys
64 type Hook a = PackageDescription -> LocalBuildInfo -> UserHooks -> a -> IO ()
65 type ConfHook = PackageDescription -> ConfigFlags -> IO LocalBuildInfo
66 type PostConfHook = Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo
69 -- type PDHook = PackageDescription -> ConfigFlags -> IO ()
71 add_ghc_options :: [String] -> Hook a -> Hook a
72 add_ghc_options args f pd lbi uhs x
73 = do let lib' = case library pd of
75 let bi = libBuildInfo lib
76 opts = options bi ++ [(GHC, args)]
77 bi' = bi { options = opts }
78 in lib { libBuildInfo = bi' }
79 Nothing -> error "Expected a library"
80 pd' = pd { library = Just lib' }
83 add_configure_options :: [String] -> PostConfHook -> PostConfHook
84 add_configure_options args f as cfs pd lbi
85 = f (as ++ args) cfs pd lbi
87 filter_modules_hook :: Hook a -> Hook a
88 filter_modules_hook f pd lbi uhs x
89 = let build_filter = case compilerFlavor $ compiler lbi of
92 lib' = case library pd of
94 let ems = filter build_filter (exposedModules lib)
95 in lib { exposedModules = ems }
96 Nothing -> error "Expected a library"
97 pd' = pd { library = Just lib' }
100 isPortableBuild :: String -> Bool
102 | "GHC" `isPrefixOf` s = False
103 | "Data.Generics" `isPrefixOf` s = False
104 | otherwise = s `notElem` ["Foreign.Concurrent", "System.Process"]
106 forGHCBuild :: String -> Bool
107 forGHCBuild = ("GHC.Prim" /=)
109 add_extra_deps :: ConfHook -> ConfHook
110 add_extra_deps f pd cf
112 case compilerFlavor (compiler lbi) of
114 do -- Euch. We should just add the right thing to the lbi
115 -- ourselves rather than rerunning configure.
116 let pd' = pd { buildDepends = Dependency "rts" AnyVersion
122 add_extra_libs :: Hook a -> Hook a
123 add_extra_libs f pd lbi uhs x
124 = let pd' = if (os == "mingw32") && (compilerFlavor (compiler lbi) == GHC)
125 then case library pd of
127 let lib_bi = libBuildInfo lib
128 lib_bi' = lib_bi { extraLibs = "wsock32"
134 lib' = lib { libBuildInfo = lib_bi' }
135 in pd { library = Just lib' }
136 Nothing -> error "Expected a library"