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