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