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 import Control.Exception (try)
  19
  20 main :: IO ()
  21 main = do let hooks = defaultUserHooks {
  22                   buildHook = build_primitive_sources
  23                             $ filter_modules_hook
  24                             $ buildHook defaultUserHooks,
  25                   makefileHook = build_primitive_sources
  26                                $ filter_modules_hook
  27                                $ makefileHook defaultUserHooks,
  28                   haddockHook = build_primitive_sources
  29                                $ filter_modules_hook
  30                                $ haddockHook defaultUserHooks,
  31                    instHook = filter_modules_hook
  32                            $ instHook defaultUserHooks }
  33           defaultMainWithHooks hooks
  34
  35 type Hook a = PackageDescription -> LocalBuildInfo -> UserHooks -> a -> IO ()
  36
  37 build_primitive_sources :: Hook a -> Hook a
  38 build_primitive_sources f pd lbi uhs x
  39  = do when (compilerFlavor (compiler lbi) == GHC) $ do
  40           let genprimopcode = joinPath ["..", "..", "utils",
  41                                         "genprimopcode", "genprimopcode"]
  42               primops = joinPath ["..", "..", "compiler", "prelude",
  43                                   "primops.txt"]
  44               primhs = joinPath ["GHC", "Prim.hs"]
  45               primopwrappers = joinPath ["GHC", "PrimopWrappers.hs"]
  46               primhs_tmp = addExtension primhs "tmp"
  47               primopwrappers_tmp = addExtension primopwrappers "tmp"
  48           maybeExit $ system (genprimopcode ++ " --make-haskell-source < "
  49                            ++ primops ++ " > " ++ primhs_tmp)
  50           maybeUpdateFile primhs_tmp primhs
  51           maybeExit $ system (genprimopcode ++ " --make-haskell-wrappers < "
  52                            ++ primops ++ " > " ++ primopwrappers_tmp)
  53           maybeUpdateFile primopwrappers_tmp primopwrappers
  54       f pd lbi uhs x
  55
  56 -- Replace a file only if the new version is different from the old.
  57 -- This prevents make from doing unnecessary work after we run 'setup makefile'
  58 maybeUpdateFile :: FilePath -> FilePath -> IO ()
  59 maybeUpdateFile source target = do
  60   r <- rawSystem "cmp" ["-s" {-quiet-}, source, target]
  61   case r of
  62     ExitSuccess   -> removeFile source
  63     ExitFailure _ -> do try (removeFile target); renameFile source target
  64
  65
  66 filter_modules_hook :: Hook a -> Hook a
  67 filter_modules_hook f pd lbi uhs x
  68  = let lib' = case library pd of
  69                   Just lib ->
  70                       let ems = filter ("GHC.Prim" /=) (exposedModules lib)
  71                       in lib { exposedModules = ems }
  72                   Nothing -> error "Expected a library"
  73        pd' = pd { library = Just lib' }
  74    in f pd' lbi uhs x
  75