Add missing case in removePrefix
[packages/old-locale.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 _ "" = Nothing
57 removePrefix (x:xs) (y:ys)
58 | x == y = removePrefix xs ys
59 | otherwise = Nothing
60
61 type Hook a = PackageDescription -> LocalBuildInfo -> Maybe UserHooks -> a
62 -> IO ()
63 type ConfHook = PackageDescription -> ConfigFlags -> IO LocalBuildInfo
64 type PostConfHook = Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo
65 -> IO ExitCode
66
67 -- type PDHook = PackageDescription -> ConfigFlags -> IO ()
68
69 add_ghc_options :: [String] -> Hook a -> Hook a
70 add_ghc_options args f pd lbi muhs x
71 = do let lib' = case library pd of
72 Just lib ->
73 let bi = libBuildInfo lib
74 opts = options bi ++ [(GHC, args)]
75 bi' = bi { options = opts }
76 in lib { libBuildInfo = bi' }
77 Nothing -> error "Expected a library"
78 pd' = pd { library = Just lib' }
79 f pd' lbi muhs x
80
81 add_configure_options :: [String] -> PostConfHook -> PostConfHook
82 add_configure_options args f as cfs pd lbi
83 = f (as ++ args) cfs pd lbi
84
85 filter_modules_hook :: Hook a -> Hook a
86 filter_modules_hook f pd lbi muhs x
87 = let build_filter = case compilerFlavor $ compiler lbi of
88 GHC -> forGHCBuild
89 _ -> isPortableBuild
90 lib' = case library pd of
91 Just lib ->
92 let ems = filter build_filter (exposedModules lib)
93 in lib { exposedModules = ems }
94 Nothing -> error "Expected a library"
95 pd' = pd { library = Just lib' }
96 in f pd' lbi muhs x
97
98 isPortableBuild :: String -> Bool
99 isPortableBuild s
100 | "GHC" `isPrefixOf` s = False
101 | "Data.Generics" `isPrefixOf` s = False
102 | otherwise = s `notElem` ["Foreign.Concurrent", "System.Process"]
103
104 forGHCBuild :: String -> Bool
105 forGHCBuild = ("GHC.Prim" /=)
106
107 add_extra_deps :: ConfHook -> ConfHook
108 add_extra_deps f pd cf
109 = do lbi <- f pd cf
110 case compilerFlavor (compiler lbi) of
111 GHC ->
112 do -- Euch. We should just add the right thing to the lbi
113 -- ourselves rather than rerunning configure.
114 let pd' = pd { buildDepends = Dependency "rts" AnyVersion
115 : buildDepends pd }
116 f pd' cf
117 _ ->
118 return lbi
119