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