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