distrib/compare/FilenameDescr.hs

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