From 351c03b8812f291f5625d3f8b6d5b096a44a7fe9 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Fri, 13 Mar 2015 08:39:50 +0200
Subject: [PATCH] Use PackageIdentifier

---
 Stackage/GhcPkg.hs       |  2 +-
 Stackage/PerformBuild.hs | 27 +++++++++++++++------------
 2 files changed, 16 insertions(+), 13 deletions(-)

diff --git a/Stackage/GhcPkg.hs b/Stackage/GhcPkg.hs
index f6c3eccf..1e5171d8 100644
--- a/Stackage/GhcPkg.hs
+++ b/Stackage/GhcPkg.hs
@@ -81,7 +81,7 @@ unregisterPackage :: (ByteString -> IO ()) -- ^ log func
                   -> FilePath -- ^ doc directory
                   -> [String] -> PackageIdentifier -> IO ()
 unregisterPackage log' docDir flags ident@(PackageIdentifier name _) = do
-    log' $ "Unregistering " ++ encodeUtf8 (display ident)
+    log' $ "Unregistering " ++ encodeUtf8 (display ident) ++ "\n"
     void (readProcessWithExitCode
               "ghc-pkg"
               ("unregister": flags ++ ["--force", unpack $ display name])
diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs
index 7a627a55..e43d0d5a 100644
--- a/Stackage/PerformBuild.hs
+++ b/Stackage/PerformBuild.hs
@@ -281,6 +281,7 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
         wfd testComps (runTests withUnpacked)
 
     pname = piName sbPackageInfo
+    pident = PackageIdentifier pname (ppVersion $ piPlan sbPackageInfo)
     name = display pname
     namever = concat
         [ name
@@ -385,7 +386,7 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
         -- dependency's haddocks before this finishes
         atomically $ putTMVar (piResult sbPackageInfo) True
 
-        prevHaddockResult <- getPreviousResult pb Haddock pname
+        prevHaddockResult <- getPreviousResult pb Haddock pident
         let needHaddock = pbEnableHaddock
                        && checkPrevResult prevHaddockResult pcHaddocks
                        && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)
@@ -424,7 +425,7 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
                                    $ modifyTVar sbHaddockFiles
                                    $ insertMap namever newPath
 
-            savePreviousResult pb Haddock pname $ either (const False) (const True) eres
+            savePreviousResult pb Haddock pident $ either (const False) (const True) eres
             case (eres, pcHaddocks) of
                 (Left e, ExpectSuccess) -> throwM e
                 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected Haddock success"
@@ -435,7 +436,7 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
     runTests withUnpacked = wf testOut $ \outH -> do
         let run = runChild outH
 
-        prevTestResult <- getPreviousResult pb Test pname
+        prevTestResult <- getPreviousResult pb Test pident
         let needTest = pbEnableTests
                     && checkPrevResult prevTestResult pcTests
         when needTest $ withUnpacked $ do
@@ -449,7 +450,7 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
                 log' $ "Test run " ++ namever
                 run "cabal" ["test", "--log=" ++ fpToText testRunOut]
 
-            savePreviousResult pb Test pname $ either (const False) (const True) eres
+            savePreviousResult pb Test pident $ either (const False) (const True) eres
             case (eres, pcTests) of
                 (Left e, ExpectSuccess) -> throwM e
                 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected test success"
@@ -501,26 +502,28 @@ data ResultType = Haddock | Test
 
 -- | The result generated on a previous run
 data PrevResult = PRNoResult | PRSuccess | PRFailure
+    deriving (Show, Enum, Eq, Ord, Bounded, Read)
 
 -- | Check if we should rerun based on a PrevResult and the expected status
+checkPrevResult :: PrevResult -> TestState -> Bool
 checkPrevResult _          Don'tBuild    = False
 checkPrevResult PRNoResult _             = True
 checkPrevResult PRSuccess  _             = False
 checkPrevResult PRFailure  ExpectSuccess = True
 checkPrevResult PRFailure  _             = False
 
-withPRPath :: PerformBuild -> ResultType -> PackageName -> (FilePath -> IO a) -> IO a
-withPRPath pb rt (PackageName name) inner = do
+withPRPath :: PerformBuild -> ResultType -> PackageIdentifier -> (FilePath -> IO a) -> IO a
+withPRPath pb rt ident inner = do
     createTree $ parent fp
     inner fp
   where
-    fp = pbPrevResDir pb </> fpFromString (show rt) </> fpFromString name
+    fp = pbPrevResDir pb </> fpFromString (show rt) </> fpFromText (display ident)
 
 successBS, failureBS :: ByteString
 successBS = "success"
 failureBS = "failure"
 
-getPreviousResult :: PerformBuild -> ResultType -> PackageName -> IO PrevResult
+getPreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> IO PrevResult
 getPreviousResult w x y = withPRPath w x y $ \fp -> do
     eres <- tryIO $ readFile fp
     return $ case eres of
@@ -529,12 +532,12 @@ getPreviousResult w x y = withPRPath w x y $ \fp -> do
             | bs == failureBS -> PRFailure
         _                     -> PRNoResult
 
-savePreviousResult :: PerformBuild -> ResultType -> PackageName -> Bool -> IO ()
-savePreviousResult pb rt name res =
-    withPRPath pb rt name $ \fp -> writeFile fp $
+savePreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> Bool -> IO ()
+savePreviousResult pb rt ident res =
+    withPRPath pb rt ident $ \fp -> writeFile fp $
         if res then successBS else failureBS
 
-deletePreviousResults :: PerformBuild -> PackageName -> IO ()
+deletePreviousResults :: PerformBuild -> PackageIdentifier -> IO ()
 deletePreviousResults pb name =
     forM_ [minBound..maxBound] $ \rt ->
     withPRPath pb rt name $ \fp ->