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