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
121
122
|
module Hadrian.BuildPath where
import Base
import Data.Functor
import qualified Text.Parsec as Parsec
-- | A path of the form
--
-- > <build root>/stage<N>/<path/to/pkg/from/ghc/root>/build/<something>
--
-- where @something@ describes a library or object file or ... to be built
-- for the given package.
--
-- @a@, which represents that @something@, is instantiated with library-related
-- data types in @Rules.Library@ and with object/interface files related types
-- in @Rules.Compile@.
data BuildPath a = BuildPath FilePath -- ^ > <build root>/
Stage -- ^ > stage<N>/
FilePath -- ^ > <path/to/pkg/from/ghc/root>/build/
a -- ^ > whatever comes after 'build/'
deriving (Eq, Show)
-- | Parse a build path under the given build root.
parseBuildPath
:: FilePath -- ^ build root
-> Parsec.Parsec String () a -- ^ what to parse after @build/@
-> Parsec.Parsec String () (BuildPath a)
parseBuildPath root afterBuild = do
_ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
stage <- parseStage
_ <- Parsec.char '/'
pkgpath <- Parsec.manyTill Parsec.anyChar
(Parsec.try $ Parsec.string "/build/")
a <- afterBuild
return (BuildPath root stage pkgpath a)
-- To be kept in sync with Stage.hs's stageString function
-- | Parse @"stageX"@ into a 'Stage'.
parseStage :: Parsec.Parsec String () Stage
parseStage = (Parsec.string "stage" *> Parsec.choice
[ Parsec.string (show n) $> toEnum n
| n <- map fromEnum [minBound .. maxBound :: Stage]
]) Parsec.<?> "stage string"
-- To be kept in sync with the show instances in 'Way.Type', until we perhaps
-- use some bidirectional parsing/pretty printing approach or library.
-- | Parse a way suffix, returning the argument when no suffix is found (the
-- argument will be vanilla in most cases, but dynamic when we parse the way
-- suffix out of a shared library file name).
parseWaySuffix :: Way -> Parsec.Parsec String () Way
parseWaySuffix w = Parsec.choice
[ Parsec.char '_' *>
(wayFromUnits <$> Parsec.sepBy1 parseWayUnit (Parsec.char '_'))
, pure w
] Parsec.<?> "way suffix (e.g _thr_p, or none for vanilla)"
-- | Same as 'parseWaySuffix', but for parsing e.g @thr_p_@
-- instead of @_thr_p@, like 'parseWaySuffix' does.
--
-- This is used to parse paths to object files,
-- in Rules.Compile.
parseWayPrefix :: Way -> Parsec.Parsec String () Way
parseWayPrefix w = Parsec.choice
[ wayFromUnits <$> Parsec.endBy1 parseWayUnit (Parsec.char '_')
, pure w
] Parsec.<?> "way prefix (e.g thr_p_, or none for vanilla)"
parseWayUnit :: Parsec.Parsec String () WayUnit
parseWayUnit = Parsec.choice
[ Parsec.string "thr" *> pure Threaded
, Parsec.char 'd' *>
(Parsec.choice [ Parsec.string "ebug" *> pure Debug
, Parsec.string "yn" *> pure Dynamic ])
, Parsec.char 'p' *> pure Profiling
, Parsec.char 'l' *> pure Logging
] Parsec.<?> "way unit (thr, debug, dyn, p, l)"
-- | Parse a @"pkgname-pkgversion"@ string into the package name and the
-- integers that make up the package version.
parsePkgId :: Parsec.Parsec String () (String, [Integer])
parsePkgId = parsePkgId' "" Parsec.<?> "package identifier (<name>-<version>)"
where
parsePkgId' currName = do
s <- Parsec.many1 Parsec.alphaNum
_ <- Parsec.char '-'
let newName = if null currName then s else currName ++ "-" ++ s
Parsec.choice [ (newName,) <$> parsePkgVersion
, parsePkgId' newName ]
-- | Parse "."-separated integers that describe a package's version.
parsePkgVersion :: Parsec.Parsec String () [Integer]
parsePkgVersion = fmap reverse (parsePkgVersion' [])
Parsec.<?> "package version"
where
parsePkgVersion' xs = do
n <- parseNatural
Parsec.choice
[ Parsec.try
(Parsec.lookAhead (Parsec.char '.' *>
(Parsec.letter <|> Parsec.char '_')
)
)
$> (n:xs)
, Parsec.char '.' *> parsePkgVersion' (n:xs)
, pure $ (n:xs) ]
-- | Parse a natural number.
parseNatural :: Parsec.Parsec String () Integer
parseNatural = (read <$> Parsec.many1 Parsec.digit) Parsec.<?> "natural number"
-- | Runs the given parser against the given path, erroring out when the parser
-- fails (because it shouldn't if the code from this module is correct).
parsePath
:: Parsec.Parsec String () a -- ^ parser to run
-> String -- ^ string describing the input source
-> FilePath -- ^ path to parse
-> Action a
parsePath p inp path = case Parsec.parse p inp path of
Left err -> fail $ "Hadrian.BuildPath.parsePath: path="
++ path ++ ", error:\n" ++ show err
Right a -> pure a
|
