distrib/compare/FilenameDescr.hs

   1
   2 module FilenameDescr where
   3
   4 import Data.Either
   5 import Data.List
   6
   7 import BuildInfo
   8 import Utils
   9 import Tar
  10
  11 -- We can't just compare plain filenames, because versions numbers of GHC
  12 -- and the libaries will vary. So we use FilenameDescr instead, which
  13 -- abstracts out the version numbers.
  14 type FilenameDescr = [FilenameDescrBit]
  15 data FilenameDescrBit = VersionOf String
  16                       | FP String
  17                       | Ways
  18     deriving (Show, Eq, Ord)
  19
  20 normalise :: FilenameDescr -> FilenameDescr
  21 normalise [] = []
  22 normalise [x] = [x]
  23 normalise (FP x1 : FP x2 : xs) = normalise (FP (x1 ++ x2) : xs)
  24 normalise (x : xs) = x : normalise xs
  25
  26 -- Sanity check that the FilenameDescr matches the filename in the tar line
  27 checkContent :: BuildInfo -> (FilenameDescr, TarLine) -> Errors
  28 checkContent buildInfo (fd, tl)
  29  = let fn = tlFileName tl
  30    in case flattenFilenameDescr buildInfo fd of
  31       Right fn' ->
  32           if fn' == fn
  33           then []
  34           else ["checkContent: Can't happen: filename mismatch: " ++ show fn]
  35       Left errs ->
  36           errs
  37
  38 flattenFilenameDescr :: BuildInfo -> FilenameDescr
  39                      -> Either Errors FilePath
  40 flattenFilenameDescr buildInfo fd = case partitionEithers (map f fd) of
  41                                     ([], strs) -> Right (concat strs)
  42                                     (errs, _) -> Left (concat errs)
  43     where f (FP fp) = Right fp
  44           f (VersionOf thing)
  45            = case lookup thing (biThingVersionMap buildInfo) of
  46              Just v -> Right v
  47              Nothing -> Left ["Can't happen: thing has no version in mapping"]
  48           f Ways = Right $ intercalate "-" $ biWays buildInfo
  49