From 12ec101e8551912039de64fcc8d4bc340d990d86 Mon Sep 17 00:00:00 2001
From: Philipp Kant <philipp@fpcomplete.com>
Date: Mon, 23 May 2016 09:53:29 +0200
Subject: [PATCH] Fix caches.

There was an issues that caused the decoding of the caches to fail (see
fpco/store#25): decodeFileMaybe tried to deserialize to a value of type
a, while the files contained values of type Tagged a.
---
 src/Data/Store/VersionTagged.hs | 14 +++++---------
 src/Stack/Build/Cache.hs        |  4 ++--
 2 files changed, 7 insertions(+), 11 deletions(-)

diff --git a/src/Data/Store/VersionTagged.hs b/src/Data/Store/VersionTagged.hs
index b1a39ee177..c864d734b0 100644
--- a/src/Data/Store/VersionTagged.hs
+++ b/src/Data/Store/VersionTagged.hs
@@ -21,7 +21,6 @@ import Data.Monoid ((<>))
 import Data.Store
 import Data.Store.TypeHash
 import qualified Data.Text as T
-import Data.Text.Encoding (encodeUtf8)
 import Path
 import Path.IO (ensureDir)
 
@@ -35,8 +34,6 @@ taggedEncodeFile fp x = do
     $logDebug $ "Encoding " <> fpt
     ensureDir (parent fp)
     let encoded = encode (Tagged x)
-    -- liftIO $ BS.appendFile "encode-log" $ encodeUtf8 fpt <> " is " <> encoded <> "DONE"
-    -- $logDebug $ "Encoded: " <> decodeUtf8 (B16.encode encoded)
     assert (decodeEx encoded == Tagged x) $ liftIO $ BS.writeFile (toFilePath fp) encoded
     $logDebug $ "Finished writing " <> fpt
 
@@ -57,11 +54,11 @@ taggedDecodeOrLoad fp mx = do
             x <- mx
             taggedEncodeFile fp x
             return x
-        Just (Tagged x) -> do
+        Just x -> do
             $logDebug $ "Success decoding " <> fpt
             return x
 
-decodeFileMaybe :: (Store a, MonadIO m, MonadLogger m, MonadBaseControl IO m)
+decodeFileMaybe :: (Store a, HasTypeHash a, MonadIO m, MonadLogger m, MonadBaseControl IO m)
                 => Path loc File
                 -> m (Maybe a)
 decodeFileMaybe fp = do
@@ -70,10 +67,9 @@ decodeFileMaybe fp = do
         return Nothing
     case mbs of
         Nothing -> return Nothing
-        Just bs -> do
-            liftIO (Just <$> decodeIO bs) `catch` \(err :: PeekException) -> do
+        Just bs ->
+            liftIO (do (Tagged res) <- decodeIO bs
+                       return (Just res)) `catch` \(err :: PeekException) -> do
                  let fpt = T.pack (toFilePath fp)
                  $logDebug ("Error while decoding " <> fpt <> ": " <> T.pack (show err) <> " (this might not be an error, when switching between stack versions)")
-                 -- liftIO $ BS.appendFile "decode-error-log" $ encodeUtf8 fpt <> " is " <> bs <> "DONE"
-                 -- $logDebug $ "Input: " <> decodeUtf8 (B16.encode bs)
                  return Nothing
diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs
index cebfa9333b..1017bcb6a7 100644
--- a/src/Stack/Build/Cache.hs
+++ b/src/Stack/Build/Cache.hs
@@ -125,7 +125,7 @@ tryGetCabalMod :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env,
 tryGetCabalMod = tryGetCache configCabalMod
 
 -- | Try to load a cache.
-tryGetCache :: (MonadIO m, Store a, MonadBaseControl IO m, MonadLogger m)
+tryGetCache :: (MonadIO m, Store a, HasTypeHash a, MonadBaseControl IO m, MonadLogger m)
             => (Path Abs Dir -> m (Path Abs File))
             -> Path Abs Dir
             -> m (Maybe a)
@@ -328,7 +328,7 @@ readPrecompiledCache pkgident copts depIDs = do
     (file, getOldFile) <- precompiledCacheFile pkgident copts depIDs
     mres <- decodeFileMaybe file
     case mres of
-        Just res -> return res
+        Just res -> return (Just res)
         Nothing -> do
             -- Fallback on trying the old binary format.
             oldFile <- getOldFile