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