Update to store-0.4.1

mgsloan · mgsloan · commit d3637126b904 · 2017-03-07T17:35:27.000-08:00
This has the side effect of invalidating all of the stored binary
caches, with the upside of having better error reporting for the future.
diff --git a/src/Data/Store/VersionTagged.hs b/src/Data/Store/VersionTagged.hs
@@ -25,6 +25,7 @@ import qualified Data.Map as M
 import Data.Monoid ((<>))
 import qualified Data.Set as S
 import Data.Store
+import Data.Store.Core (unsafeEncodeWith)
 import Data.Store.Version
 import qualified Data.Text as T
 import Language.Haskell.TH
@@ -33,65 +34,65 @@ import Path.IO (ensureDir)
 import Prelude
 
 versionedEncodeFile :: Data a => VersionConfig a -> Q Exp
-versionedEncodeFile vc = [e| \fp x -> storeEncodeFile fp ($(wrapVersion vc) x) |]
+versionedEncodeFile vc = [e| storeEncodeFile $(encodeWithVersionQ vc) $(decodeWithVersionQ vc) |]
 
 versionedDecodeOrLoad :: Data a => VersionConfig a -> Q Exp
-versionedDecodeOrLoad vc = [| versionedDecodeOrLoadImpl $(wrapVersion vc) $(checkVersion vc) |]
+versionedDecodeOrLoad vc = [| versionedDecodeOrLoadImpl $(encodeWithVersionQ vc) $(decodeWithVersionQ vc) |]
 
 versionedDecodeFile :: Data a => VersionConfig a -> Q Exp
-versionedDecodeFile vc = [e| versionedDecodeFileImpl $(checkVersion vc) |]
+versionedDecodeFile vc = [e| versionedDecodeFileImpl $(decodeWithVersionQ vc) |]
 
 -- | Write to the given file.
 storeEncodeFile :: (Store a, MonadIO m, MonadLogger m, Eq a)
-                => Path Abs File
+                => (a -> (Int, Poke ()))
+                -> Peek a
+                -> Path Abs File
                 -> a
                 -> m ()
-storeEncodeFile fp x = do
+storeEncodeFile pokeFunc peekFunc fp x = do
     let fpt = T.pack (toFilePath fp)
     $logDebug $ "Encoding " <> fpt
     ensureDir (parent fp)
-    let encoded = encode x
-    assert (decodeEx encoded == x) $ liftIO $ BS.writeFile (toFilePath fp) encoded
+    let (sz, poker) = pokeFunc x
+        encoded = unsafeEncodeWith poker sz
+    assert (decodeExWith peekFunc encoded == x) $ liftIO $ BS.writeFile (toFilePath fp) encoded
     $logDebug $ "Finished writing " <> fpt
 
 -- | Read from the given file. If the read fails, run the given action and
 -- write that back to the file. Always starts the file off with the
 -- version tag.
 versionedDecodeOrLoadImpl :: (Store a, Eq a, MonadIO m, MonadLogger m, MonadBaseControl IO m)
-                          => (a -> WithVersion a)
-                          -> (WithVersion a -> Either VersionCheckException a)
+                          => (a -> (Int, Poke ()))
+                          -> Peek a
                           -> Path Abs File
                           -> m a
                           -> m a
-versionedDecodeOrLoadImpl wrap check fp mx = do
+versionedDecodeOrLoadImpl pokeFunc peekFunc fp mx = do
     let fpt = T.pack (toFilePath fp)
     $logDebug $ "Trying to decode " <> fpt
-    mres <- versionedDecodeFileImpl check fp
+    mres <- versionedDecodeFileImpl peekFunc fp
     case mres of
         Just x -> do
             $logDebug $ "Success decoding " <> fpt
             return x
         _ -> do
             $logDebug $ "Failure decoding " <> fpt
             x <- mx
-            storeEncodeFile fp (wrap x)
+            storeEncodeFile pokeFunc peekFunc fp x
             return x
 
 versionedDecodeFileImpl :: (Store a, MonadIO m, MonadLogger m, MonadBaseControl IO m)
-                        => (WithVersion a -> Either VersionCheckException a)
+                        => Peek a
                         -> Path loc File
                         -> m (Maybe a)
-versionedDecodeFileImpl check fp = do
+versionedDecodeFileImpl peekFunc fp = do
     mbs <- liftIO (Just <$> BS.readFile (toFilePath fp)) `catch` \(err :: IOException) -> do
         $logDebug ("Exception ignored when attempting to load " <> T.pack (toFilePath fp) <> ": " <> T.pack (show err))
         return Nothing
     case mbs of
         Nothing -> return Nothing
         Just bs ->
-            liftIO (do decoded <- decodeIO bs
-                       return $ case check decoded of
-                           Right res -> Just res
-                           _ -> Nothing) `catch` \(err :: PeekException) -> do
+            liftIO (Just <$> decodeIOWith peekFunc bs) `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)")
                  return Nothing
diff --git a/stack-8.0.yaml b/stack-8.0.yaml
@@ -9,7 +9,7 @@ nix:
   packages:
     - zlib
 extra-deps:
-- store-0.3.1
-- store-core-0.3
+- store-0.4.1
+- store-core-0.4
 - th-utilities-0.2.0.1
 - http-client-tls-0.3.4
diff --git a/stack-nightly.yaml b/stack-nightly.yaml
@@ -3,6 +3,9 @@ image:
   containers:
     - base: "fpco/stack-base" # see ./etc/docker/stack-base/Dockerfile
       name: "fpco/stack-test"
+extra-deps:
+- store-0.4.1
+- store-core-0.4
 nix:
   # --nix on the command-line to enable.
   enable: false
diff --git a/stack.cabal b/stack.cabal
@@ -273,7 +273,8 @@ library
                    , project-template >= 0.2
                    , zip-archive < 0.4
                    , hpack >= 0.17.0 && < 0.18
-                   , store >= 0.2.1.0
+                   , store >= 0.4.1 && < 0.5
+                   , store-core >= 0.4 && < 0.5
                    , annotated-wl-pprint
                    , file-embed >= 0.0.10
   if os(windows)
@@ -378,7 +379,7 @@ test-suite stack-test
                 , th-reify-many
                 , smallcheck
                 , bytestring
-                , store >= 0.2.1.0
+                , store >= 0.4.1 && < 0.5
                 , vector >= 0.10.12.3 && < 0.13
                 , unordered-containers
                 , template-haskell
diff --git a/stack.yaml b/stack.yaml
@@ -14,8 +14,8 @@ nix:
 extra-deps:
 - Cabal-1.24.2.0
 - th-utilities-0.2.0.1
-- store-0.3
-- store-core-0.3
+- store-0.4.1
+- store-core-0.4
 - th-orphans-0.13.1
 - http-client-0.5.3.3
 - http-client-tls-0.3.4
