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