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