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.PackageDescription
  12 import Distribution.Setup
  13 import Distribution.Simple
  14 import Distribution.Simple.LocalBuildInfo
  15 import Distribution.Simple.Utils
  16 import System.Cmd
  17 import System.Environment
  18 import System.Info
  19
  20 main :: IO ()
  21 main = do args <- getArgs
  22           let (ghcArgs, args') = extractGhcArgs args
  23               (confArgs, args'') = extractConfigureArgs args'
  24               hooks = defaultUserHooks {
  25                   confHook = add_extra_deps
  26                            $ confHook defaultUserHooks,
  27                   postConf = add_configure_options confArgs
  28                            $ postConf defaultUserHooks,
  29                   buildHook = build_primitive_sources
  30                             $ add_ghc_options ghcArgs
  31                             $ filter_modules_hook
  32                             $ buildHook defaultUserHooks,
  33                   makefileHook = add_ghc_options ghcArgs
  34                                $ filter_modules_hook
  35                                $ makefileHook defaultUserHooks,
  36                   regHook = add_extra_libs
  37                           $ regHook defaultUserHooks,
  38                   instHook = filter_modules_hook
  39                            $ instHook defaultUserHooks }
  40           withArgs args'' $ defaultMainWithHooks hooks
  41
  42 extractGhcArgs :: [String] -> ([String], [String])
  43 extractGhcArgs = extractPrefixArgs "--ghc-option="
  44
  45 extractConfigureArgs :: [String] -> ([String], [String])
  46 extractConfigureArgs = extractPrefixArgs "--configure-option="
  47
  48 extractPrefixArgs :: String -> [String] -> ([String], [String])
  49 extractPrefixArgs the_prefix args
  50  = let f [] = ([], [])
  51        f (x:xs) = case f xs of
  52                       (wantedArgs, otherArgs) ->
  53                           case removePrefix the_prefix x of
  54                               Just wantedArg ->
  55                                   (wantedArg:wantedArgs, otherArgs)
  56                               Nothing ->
  57                                   (wantedArgs, x:otherArgs)
  58    in f args
  59
  60 removePrefix :: String -> String -> Maybe String
  61 removePrefix "" ys = Just ys
  62 removePrefix _  "" = Nothing
  63 removePrefix (x:xs) (y:ys)
  64  | x == y = removePrefix xs ys
  65  | otherwise = Nothing
  66
  67 type Hook a = PackageDescription -> LocalBuildInfo -> UserHooks -> a -> IO ()
  68 type ConfHook = PackageDescription -> ConfigFlags -> IO LocalBuildInfo
  69 type PostConfHook = Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo
  70                  -> IO ()
  71
  72 -- type PDHook = PackageDescription -> ConfigFlags -> IO ()
  73
  74 build_primitive_sources :: Hook a -> Hook a
  75 build_primitive_sources f pd lbi uhs x
  76  = do when (compilerFlavor (compiler lbi) == GHC) $ do
  77           maybeExit $ system "../../utils/genprimopcode/genprimopcode --make-haskell-source < ../../compiler/prelude/primops.txt > GHC/Prim.hs"
  78           maybeExit $ system "../../utils/genprimopcode/genprimopcode --make-haskell-wrappers < ../../compiler/prelude/primops.txt > GHC/PrimopWrappers.hs"
  79       f pd lbi uhs x
  80
  81 add_ghc_options :: [String] -> Hook a -> Hook a
  82 add_ghc_options args f pd lbi uhs x
  83  = do let lib' = case library pd of
  84                      Just lib ->
  85                          let bi = libBuildInfo lib
  86                              opts = options bi ++ [(GHC, args)]
  87                              bi' = bi { options = opts }
  88                          in lib { libBuildInfo = bi' }
  89                      Nothing -> error "Expected a library"
  90           pd' = pd { library = Just lib' }
  91       f pd' lbi uhs x
  92
  93 add_configure_options :: [String] -> PostConfHook -> PostConfHook
  94 add_configure_options args f as cfs pd lbi
  95  = f (as ++ args) cfs pd lbi
  96
  97 filter_modules_hook :: Hook a -> Hook a
  98 filter_modules_hook f pd lbi uhs x
  99  = let build_filter = case compilerFlavor $ compiler lbi of
 100                           GHC -> forGHCBuild
 101                           _ -> isPortableBuild
 102        lib' = case library pd of
 103                   Just lib ->
 104                       let ems = filter build_filter (exposedModules lib)
 105                       in lib { exposedModules = ems }
 106                   Nothing -> error "Expected a library"
 107        pd' = pd { library = Just lib' }
 108    in f pd' lbi uhs x
 109
 110 isPortableBuild :: String -> Bool
 111 isPortableBuild s
 112  | "GHC" `isPrefixOf` s = False
 113  | "Data.Generics" `isPrefixOf` s = False
 114  | otherwise = s `notElem` ["Foreign.Concurrent", "System.Process"]
 115
 116 forGHCBuild :: String -> Bool
 117 forGHCBuild = ("GHC.Prim" /=)
 118
 119 add_extra_deps :: ConfHook -> ConfHook
 120 add_extra_deps f pd cf
 121  = do lbi <- f pd cf
 122       case compilerFlavor (compiler lbi) of
 123           GHC ->
 124               do -- Euch. We should just add the right thing to the lbi
 125                  -- ourselves rather than rerunning configure.
 126                  let pd' = pd { buildDepends = Dependency "rts" AnyVersion
 127                                              : buildDepends pd }
 128                  f pd' cf
 129           _ ->
 130               return lbi
 131
 132 add_extra_libs :: Hook a -> Hook a
 133 add_extra_libs f pd lbi uhs x
 134  = let pd' = if (os == "mingw32") && (compilerFlavor (compiler lbi) == GHC)
 135              then case library pd of
 136                   Just lib ->
 137                       let lib_bi = libBuildInfo lib
 138                           lib_bi' = lib_bi { extraLibs = "wsock32"
 139                                                        : "msvcrt"
 140                                                        : "kernel32"
 141                                                        : "user32"
 142                                                        : "shell32"
 143                                                        : extraLibs lib_bi }
 144                           lib' = lib { libBuildInfo = lib_bi' }
 145                       in pd { library = Just lib' }
 146                   Nothing -> error "Expected a library"
 147              else pd
 148    in f pd' lbi uhs x
 149