a0f53fd2a0dfc7d1cdda15228853f0982209b57b
[ghc.git] / distrib / compare / FilenameDescr.hs
1
2 module FilenameDescr where
3
4 import Data.Char
5 import Data.Either
6 import Data.List
7
8 import BuildInfo
9 import Utils
10 import Tar
11
12 -- We can't just compare plain filenames, because versions numbers of GHC
13 -- and the libaries will vary. So we use FilenameDescr instead, which
14 -- abstracts out the version numbers.
15 type FilenameDescr = [FilenameDescrBit]
16 data FilenameDescrBit = VersionOf String
17 | HashOf String
18 | FP String
19 | Ways
20 deriving (Show, Eq, Ord)
21
22 normaliseDescr :: FilenameDescr -> FilenameDescr
23 normaliseDescr [] = []
24 normaliseDescr [x] = [x]
25 normaliseDescr (FP x1 : FP x2 : xs) = normaliseDescr (FP (x1 ++ x2) : xs)
26 normaliseDescr (x : xs) = x : normaliseDescr xs
27
28 -- Sanity check that the FilenameDescr matches the filename in the tar line
29 checkContent :: BuildInfo -> (FilenameDescr, TarLine) -> Errors
30 checkContent buildInfo (fd, tl)
31 = let fn = tlFileName tl
32 in case flattenFilenameDescr buildInfo fd of
33 Right fn' ->
34 if fn' == fn
35 then []
36 else if all isAscii fn
37 then ["checkContent: Can't happen: filename mismatch: "
38 ++ show fn]
39 else [] -- Ugly kludge; don't worry too much if filepaths
40 -- containing non-ASCII chars have gone wrong
41 Left errs ->
42 errs
43
44 flattenFilenameDescr :: BuildInfo -> FilenameDescr
45 -> Either Errors FilePath
46 flattenFilenameDescr buildInfo fd = case partitionEithers (map f fd) of
47 ([], strs) -> Right (concat strs)
48 (errs, _) -> Left (concat errs)
49 where f (FP fp) = Right fp
50 f (VersionOf thing)
51 = case lookup thing (biThingVersionMap buildInfo) of
52 Just v -> Right v
53 Nothing -> Left ["Can't happen: thing has no version in mapping"]
54 f (HashOf thing)
55 = case lookup thing (biThingHashMap buildInfo) of
56 Just v -> Right v
57 Nothing -> Left ["Can't happen: thing has no hash in mapping"]
58 f Ways = case biMaybeWays buildInfo of
59 Just ways -> Right $ intercalate "-" ways
60 Nothing -> Left ["Can't happen: No ways, but Ways is used"]
61