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
|
-- Note [Settings file]
-- ~~~~~~~~~~~~~~~~~~~~
--
-- GHC has a file, `${top_dir}/settings`, which is the main source of run-time
-- configuration. ghc-pkg needs just a little bit of it: the target platform CPU
-- arch and OS. It uses that to figure out what subdirectory of `~/.ghc` is
-- associated with the current version/target.
--
-- This module has just enough code to read key value pairs from the settings
-- file, and read the target platform from those pairs.
--
-- The "0" suffix is because the caller will partially apply it, and that will
-- in turn be used a few more times.
module GHC.Settings where
import Prelude -- See Note [Why do we import Prelude here?]
import GHC.BaseDir
import GHC.Platform
import Data.Char (isSpace)
import Data.Map (Map)
import qualified Data.Map as Map
-----------------------------------------------------------------------------
-- parts of settings file
getTargetPlatform
:: FilePath -> RawSettings -> Either String Platform
getTargetPlatform settingsFile mySettings = do
let
getBooleanSetting = getBooleanSetting0 settingsFile mySettings
readSetting :: (Show a, Read a) => String -> Either String a
readSetting = readSetting0 settingsFile mySettings
targetArch <- readSetting "target arch"
targetOS <- readSetting "target os"
targetWordSize <- readSetting "target word size"
targetUnregisterised <- getBooleanSetting "Unregisterised"
targetHasGnuNonexecStack <- getBooleanSetting "target has GNU nonexec stack"
targetHasIdentDirective <- getBooleanSetting "target has .ident directive"
targetHasSubsectionsViaSymbols <- getBooleanSetting "target has subsections via symbols"
crossCompiling <- getBooleanSetting "cross compiling"
pure $ Platform
{ platformArch = targetArch
, platformOS = targetOS
, platformWordSize = targetWordSize
, platformUnregisterised = targetUnregisterised
, platformHasGnuNonexecStack = targetHasGnuNonexecStack
, platformHasIdentDirective = targetHasIdentDirective
, platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols
, platformIsCrossCompiling = crossCompiling
}
-----------------------------------------------------------------------------
-- settings file helpers
type RawSettings = Map String String
-- | See Note [Settings file] for "0" suffix
getSetting0
:: FilePath -> RawSettings -> String -> Either String String
getSetting0 settingsFile mySettings key = case Map.lookup key mySettings of
Just xs -> Right xs
Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile
-- | See Note [Settings file] for "0" suffix
getFilePathSetting0
:: FilePath -> FilePath -> RawSettings -> String -> Either String String
getFilePathSetting0 top_dir settingsFile mySettings key =
expandTopDir top_dir <$> getSetting0 settingsFile mySettings key
-- | See Note [Settings file] for "0" suffix
getBooleanSetting0
:: FilePath -> RawSettings -> String -> Either String Bool
getBooleanSetting0 settingsFile mySettings key = do
rawValue <- getSetting0 settingsFile mySettings key
case rawValue of
"YES" -> Right True
"NO" -> Right False
xs -> Left $ "Bad value for " ++ show key ++ ": " ++ show xs
-- | See Note [Settings file] for "0" suffix
readSetting0
:: (Show a, Read a) => FilePath -> RawSettings -> String -> Either String a
readSetting0 settingsFile mySettings key = case Map.lookup key mySettings of
Just xs -> case maybeRead xs of
Just v -> Right v
Nothing -> Left $ "Failed to read " ++ show key ++ " value " ++ show xs
Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile
-----------------------------------------------------------------------------
-- read helpers
maybeRead :: Read a => String -> Maybe a
maybeRead str = case reads str of
[(x, "")] -> Just x
_ -> Nothing
maybeReadFuzzy :: Read a => String -> Maybe a
maybeReadFuzzy str = case reads str of
[(x, s)] | all isSpace s -> Just x
_ -> Nothing
|
