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