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