Allow additional options to pass on to ./configure to be given
[packages/old-time.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.Simple
12 import Distribution.PackageDescription
13 import Distribution.PreProcess
14 import Distribution.Setup
15 import Distribution.Simple.Configure
16 import Distribution.Simple.LocalBuildInfo
17 import System.Environment
18 import System.Exit
19
20 main :: IO ()
21 main = do args <- getArgs
22 let (ghcArgs, args') = extractGhcArgs args
23 (configureArgs, args'') = extractConfigureArgs args'
24 hooks = defaultUserHooks {
25 confHook = add_extra_deps
26 $ confHook defaultUserHooks,
27 postConf = add_configure_options configureArgs
28 $ postConf defaultUserHooks,
29 buildHook = add_ghc_options ghcArgs
30 $ filter_modules_hook
31 $ buildHook defaultUserHooks,
32 instHook = filter_modules_hook
33 $ instHook defaultUserHooks }
34 withArgs args'' $ defaultMainWithHooks hooks
35
36 extractGhcArgs :: [String] -> ([String], [String])
37 extractGhcArgs = extractPrefixArgs "--ghc-option="
38
39 extractConfigureArgs :: [String] -> ([String], [String])
40 extractConfigureArgs = extractPrefixArgs "--configure-option="
41
42 extractPrefixArgs :: String -> [String] -> ([String], [String])
43 extractPrefixArgs prefix args
44 = let f [] = ([], [])
45 f (x:xs) = case f xs of
46 (wantedArgs, otherArgs) ->
47 case removePrefix prefix x of
48 Just wantedArg ->
49 (wantedArg:wantedArgs, otherArgs)
50 Nothing ->
51 (wantedArgs, x:otherArgs)
52 in f args
53
54 removePrefix :: String -> String -> Maybe String
55 removePrefix "" ys = Just ys
56 removePrefix (x:xs) (y:ys)
57 | x == y = removePrefix xs ys
58 | otherwise = Nothing
59
60 type Hook a = PackageDescription -> LocalBuildInfo -> Maybe UserHooks -> a
61 -> IO ()
62 type ConfHook = PackageDescription -> ConfigFlags -> IO LocalBuildInfo
63 type PostConfHook = Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo
64 -> IO ExitCode
65
66 -- type PDHook = PackageDescription -> ConfigFlags -> IO ()
67
68 add_ghc_options :: [String] -> Hook a -> Hook a
69 add_ghc_options args f pd lbi muhs x
70 = do let lib' = case library pd of
71 Just lib ->
72 let bi = libBuildInfo lib
73 opts = options bi ++ [(GHC, args)]
74 bi' = bi { options = opts }
75 in lib { libBuildInfo = bi' }
76 Nothing -> error "Expected a library"
77 pd' = pd { library = Just lib' }
78 f pd' lbi muhs x
79
80 add_configure_options :: [String] -> PostConfHook -> PostConfHook
81 add_configure_options args f as cfs pd lbi
82 = f (as ++ args) cfs pd lbi
83
84 filter_modules_hook :: Hook a -> Hook a
85 filter_modules_hook f pd lbi muhs x
86 = let build_filter = case compilerFlavor $ compiler lbi of
87 GHC -> forGHCBuild
88 _ -> isPortableBuild
89 lib' = case library pd of
90 Just lib ->
91 let ems = filter build_filter (exposedModules lib)
92 in lib { exposedModules = ems }
93 Nothing -> error "Expected a library"
94 pd' = pd { library = Just lib' }
95 in f pd' lbi muhs x
96
97 isPortableBuild :: String -> Bool
98 isPortableBuild s
99 | "GHC" `isPrefixOf` s = False
100 | "Data.Generics" `isPrefixOf` s = False
101 | otherwise = s `notElem` ["Foreign.Concurrent", "System.Process"]
102
103 forGHCBuild :: String -> Bool
104 forGHCBuild = ("GHC.Prim" /=)
105
106 add_extra_deps :: ConfHook -> ConfHook
107 add_extra_deps f pd cf
108 = do lbi <- f pd cf
109 case compilerFlavor (compiler lbi) of
110 GHC ->
111 do -- Euch. We should just add the right thing to the lbi
112 -- ourselves rather than rerunning configure.
113 let pd' = pd { buildDepends = Dependency "rts" AnyVersion
114 : buildDepends pd }
115 f pd' cf
116 _ ->
117 return lbi
118