bindist checker improvements

[ghc-hetmet.git] / distrib / compare / BuildInfo.hs

diff --git a/distrib/compare/BuildInfo.hs b/distrib/compare/BuildInfo.hs
index 547e5ac..d71eeb4 100644 (file)
--- a/distrib/compare/BuildInfo.hs
+++ b/distrib/compare/BuildInfo.hs
@@ -3,39 +3,61 @@ module BuildInfo where
 
 import Control.Monad.State
 
+type BIMonad = StateT BuildInfo Maybe
+
 data BuildInfo = BuildInfo {
                      biThingVersionMap :: ThingVersionMap,
+                     biThingHashMap :: ThingHashMap,
                      biWays :: Ways
                  }
+    deriving Show
+
+type ThingMap = [(String, String)]
 -- Mapping from thing (e.g. "Cabal") to version (e.g. "1.10.0.0")
-type ThingVersionMap = [(String, String)]
+type ThingVersionMap = ThingMap
+-- Mapping from thing (e.g. "Cabal") to ABI hash
+-- (e.g. "e1f7c380581d61d42b0360d440cc35ed")
+type ThingHashMap = ThingMap
 -- The list of ways in the order the build system uses them, e.g.
 -- ["v", "p", "dyn"] => we have ".depend-v-p-dyn.haskell" files
 type Ways = [String]
 
-addThingVersion :: ThingVersionMap -> String -> String -> Maybe ThingVersionMap
-addThingVersion mapping thing version
+emptyBuildInfo :: Ways -> BuildInfo
+emptyBuildInfo ways = BuildInfo {
+                          biThingVersionMap = [],
+                          biThingHashMap = [],
+                          biWays = ways
+                      }
+
+addThingMap :: ThingMap -> String -> String -> Maybe ThingMap
+addThingMap mapping thing str
  = case lookup thing mapping of
-   Just version' ->
-       if version == version'
+   Just str' ->
+       if str == str'
        then Just mapping
        else Nothing
    Nothing ->
-       Just ((thing, version) : mapping)
+       Just ((thing, str) : mapping)
 
-getThingVersionMap :: State BuildInfo ThingVersionMap
-getThingVersionMap = do st <- get
-                        return $ biThingVersionMap st
-
-getWays :: State BuildInfo Ways
+getWays :: BIMonad Ways
 getWays = do st <- get
              return $ biWays st
 
-putThingVersionMap :: ThingVersionMap -> State BuildInfo ()
-putThingVersionMap tm = do st <- get
-                           put $ st { biThingVersionMap = tm }
-
-putWays :: Ways -> State BuildInfo ()
+haveThingVersion :: String -> String -> BIMonad ()
+haveThingVersion thing thingVersion
+ = do st <- get
+      case addThingMap (biThingVersionMap st) thing thingVersion of
+          Nothing  -> fail "Inconsistent version"
+          Just tvm -> put $ st { biThingVersionMap = tvm }
+
+haveThingHash :: String -> String -> BIMonad ()
+haveThingHash thing thingHash
+ = do st <- get
+      case addThingMap (biThingHashMap st) thing thingHash of
+          Nothing  -> fail "Inconsistent hash"
+          Just thm -> put $ st { biThingHashMap = thm }
+
+putWays :: Ways -> BIMonad ()
 putWays ws = do st <- get
                 put $ st { biWays = ws }