1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
|
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE LambdaCase #-}
module Main where
import Distribution.Simple
import Distribution.Simple.BuildPaths
import Distribution.Types.LocalBuildInfo
import Distribution.Verbosity
import Distribution.Simple.Program
import Distribution.Simple.Utils
import Distribution.Simple.Setup
import System.IO
import System.Directory
import System.FilePath
import System.Environment
import Control.Monad
import Data.Char
import GHC.ResponseFile
main :: IO ()
main = defaultMainWithHooks ghcHooks
where
ghcHooks = simpleUserHooks
{ postConf = \args cfg pd lbi -> do
let verbosity = fromFlagOrDefault minBound (configVerbosity cfg)
ghcAutogen verbosity lbi
postConf simpleUserHooks args cfg pd lbi
}
ghcAutogen :: Verbosity -> LocalBuildInfo -> IO ()
ghcAutogen verbosity lbi@LocalBuildInfo{..} = do
-- Get compiler/ root directory from the cabal file
let Just compilerRoot = takeDirectory <$> pkgDescrFile
let platformHostFile = "GHC/Platform/Host.hs"
platformHostPath = autogenPackageModulesDir lbi </> platformHostFile
ghcVersionFile = "GHC/Version.hs"
ghcVersionPath = autogenPackageModulesDir lbi </> ghcVersionFile
-- Get compiler settings
settings <- lookupEnv "HADRIAN_SETTINGS" >>= \case
Just settings -> pure $ Left $ read settings
Nothing -> do
(ghc,withPrograms) <- requireProgram normal ghcProgram withPrograms
Right . read <$> getProgramOutput normal ghc ["--info"]
-- Write GHC.Platform.Host
createDirectoryIfMissingVerbose verbosity True (takeDirectory platformHostPath)
rewriteFileEx verbosity platformHostPath (generatePlatformHostHs settings)
-- Write GHC.Version
createDirectoryIfMissingVerbose verbosity True (takeDirectory ghcVersionPath)
rewriteFileEx verbosity ghcVersionPath (generateVersionHs settings)
-- | Takes either a list of hadrian generated settings, or a list of settings from ghc --info,
-- and keys in both lists, and looks up the value in the appropriate list
getSetting :: Either [(String,String)] [(String,String)] -> String -> String -> Either String String
getSetting settings kh kr = case settings of
Left settings -> go settings kh
Right settings -> go settings kr
where
go settings k = case lookup k settings of
Nothing -> Left (show k ++ " not found in settings: " ++ show settings)
Just v -> Right v
generatePlatformHostHs :: Either [(String,String)] [(String,String)] -> String
generatePlatformHostHs settings = either error id $ do
let getSetting' = getSetting settings
cHostPlatformArch <- getSetting' "hostPlatformArch" "target arch"
cHostPlatformOS <- getSetting' "hostPlatformOS" "target os"
return $ unlines
[ "module GHC.Platform.Host where"
, ""
, "import GHC.Platform.ArchOS"
, ""
, "hostPlatformArch :: Arch"
, "hostPlatformArch = " ++ cHostPlatformArch
, ""
, "hostPlatformOS :: OS"
, "hostPlatformOS = " ++ cHostPlatformOS
, ""
, "hostPlatformArchOS :: ArchOS"
, "hostPlatformArchOS = ArchOS hostPlatformArch hostPlatformOS"
]
generateVersionHs :: Either [(String,String)] [(String,String)] -> String
generateVersionHs settings = either error id $ do
let getSetting' = getSetting settings
cProjectGitCommitId <- getSetting' "cProjectGitCommitId" "Project Git commit id"
cProjectVersion <- getSetting' "cProjectVersion" "Project version"
cProjectVersionInt <- getSetting' "cProjectVersionInt" "Project Version Int"
cProjectPatchLevel <- getSetting' "cProjectPatchLevel" "Project Patch Level"
cProjectPatchLevel1 <- getSetting' "cProjectPatchLevel1" "Project Patch Level1"
cProjectPatchLevel2 <- getSetting' "cProjectPatchLevel2" "Project Patch Level2"
return $ unlines
[ "module GHC.Version where"
, ""
, "import Prelude -- See Note [Why do we import Prelude here?]"
, ""
, "cProjectGitCommitId :: String"
, "cProjectGitCommitId = " ++ show cProjectGitCommitId
, ""
, "cProjectVersion :: String"
, "cProjectVersion = " ++ show cProjectVersion
, ""
, "cProjectVersionInt :: String"
, "cProjectVersionInt = " ++ show cProjectVersionInt
, ""
, "cProjectPatchLevel :: String"
, "cProjectPatchLevel = " ++ show cProjectPatchLevel
, ""
, "cProjectPatchLevel1 :: String"
, "cProjectPatchLevel1 = " ++ show cProjectPatchLevel1
, ""
, "cProjectPatchLevel2 :: String"
, "cProjectPatchLevel2 = " ++ show cProjectPatchLevel2
]
|
