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
  17 main :: IO ()
  18 main = do args <- getArgs
  19           let (ghcArgs, args') = extractGhcArgs args
  20               (confArgs, args'') = extractConfigureArgs args'
  21               hooks = defaultUserHooks {
  22                   confHook = add_extra_deps
  23                            $ confHook defaultUserHooks,
  24                   postConf = add_configure_options confArgs
  25                            $ postConf defaultUserHooks,
  26                   buildHook = add_ghc_options ghcArgs
  27                             $ filter_modules_hook
  28                             $ buildHook defaultUserHooks,
  29                   makefileHook = add_ghc_options ghcArgs
  30                             $ filter_modules_hook
  31                             $ makefileHook 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 the_prefix args
  44  = let f [] = ([], [])
  45        f (x:xs) = case f xs of
  46                       (wantedArgs, otherArgs) ->
  47                           case removePrefix the_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 -> UserHooks -> a -> IO ()
  62 type ConfHook = PackageDescription -> ConfigFlags -> IO LocalBuildInfo
  63 type PostConfHook = Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo
  64                  -> IO ()
  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 uhs 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 uhs 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 uhs 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 uhs 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