Setup.hs

   1 {-
   2 We need to do some ugly hacks here as base mix of portable and
   3 unportable stuff, as well as home to some GHC magic.
   4 -}
   5
   6 module Main (main) where
   7
   8 import Control.Monad
   9 import Data.List
  10 import Distribution.PackageDescription
  11 import Distribution.Simple
  12 import Distribution.Simple.LocalBuildInfo
  13 import Distribution.Simple.Utils
  14 import System.Cmd
  15 import System.FilePath
  16 import System.Exit
  17 import System.Directory
  18
  19 main :: IO ()
  20 main = do let hooks = defaultUserHooks {
  21                   buildHook = build_primitive_sources
  22                             $ filter_modules_hook
  23                             $ buildHook defaultUserHooks,
  24                   makefileHook = build_primitive_sources
  25                                $ filter_modules_hook
  26                                $ makefileHook defaultUserHooks,
  27                   haddockHook = build_primitive_sources
  28                                $ filter_modules_hook
  29                                $ haddockHook defaultUserHooks,
  30                    instHook = filter_modules_hook
  31                            $ instHook defaultUserHooks }
  32           defaultMainWithHooks hooks
  33
  34 type Hook a = PackageDescription -> LocalBuildInfo -> UserHooks -> a -> IO ()
  35
  36 build_primitive_sources :: Hook a -> Hook a
  37 build_primitive_sources f pd lbi uhs x
  38  = do when (compilerFlavor (compiler lbi) == GHC) $ do
  39           let genprimopcode = joinPath ["..", "..", "utils",
  40                                         "genprimopcode", "genprimopcode"]
  41               primops = joinPath ["..", "..", "compiler", "prelude",
  42                                   "primops.txt"]
  43               primhs = joinPath ["GHC", "Prim.hs"]
  44               primopwrappers = joinPath ["GHC", "PrimopWrappers.hs"]
  45               primhs_tmp = addExtension primhs "tmp"
  46               primopwrappers_tmp = addExtension primopwrappers "tmp"
  47           maybeExit $ system (genprimopcode ++ " --make-haskell-source < "
  48                            ++ primops ++ " > " ++ primhs_tmp)
  49           maybeUpdateFile primhs_tmp primhs
  50           maybeExit $ system (genprimopcode ++ " --make-haskell-wrappers < "
  51                            ++ primops ++ " > " ++ primopwrappers_tmp)
  52           maybeUpdateFile primopwrappers_tmp primopwrappers
  53       f pd lbi uhs x
  54
  55 -- Replace a file only if the new version is different from the old.
  56 -- This prevents make from doing unnecessary work after we run 'setup makefile'
  57 maybeUpdateFile :: FilePath -> FilePath -> IO ()
  58 maybeUpdateFile source target = do
  59   r <- rawSystem "cmp" ["-s" {-quiet-}, source, target]
  60   case r of
  61     ExitSuccess   -> return ()
  62     ExitFailure _ -> copyFile source target
  63   removeFile source
  64
  65 filter_modules_hook :: Hook a -> Hook a
  66 filter_modules_hook f pd lbi uhs x
  67  = let lib' = case library pd of
  68                   Just lib ->
  69                       let ems = filter ("GHC.Prim" /=) (exposedModules lib)
  70                       in lib { exposedModules = ems }
  71                   Nothing -> error "Expected a library"
  72        pd' = pd { library = Just lib' }
  73    in f pd' lbi uhs x
  74