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