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