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