Setup.hs

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