module Data.Store.VersionTagged
( versionedEncodeFile
, versionedDecodeOrLoad
, versionedDecodeFile
, storeVersionConfig
) where
import Stack.Prelude
import qualified Data.ByteString as BS
import qualified Data.Map as M
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
import Path
import Path.IO (ensureDir)
versionedEncodeFile :: Data a => VersionConfig a -> Q Exp
versionedEncodeFile vc = [e| storeEncodeFile $(encodeWithVersionQ vc) $(decodeWithVersionQ vc) |]
versionedDecodeOrLoad :: Data a => VersionConfig a -> Q Exp
versionedDecodeOrLoad vc = [| versionedDecodeOrLoadImpl $(encodeWithVersionQ vc) $(decodeWithVersionQ vc) |]
versionedDecodeFile :: Data a => VersionConfig a -> Q Exp
versionedDecodeFile vc = [e| versionedDecodeFileImpl $(decodeWithVersionQ vc) |]
storeEncodeFile :: (Store a, MonadIO m, MonadLogger m, Eq a)
=> (a -> (Int, Poke ()))
-> Peek a
-> Path Abs File
-> a
-> m ()
storeEncodeFile pokeFunc peekFunc fp x = do
let fpt = T.pack (toFilePath fp)
logDebug $ "Encoding " <> fpt
ensureDir (parent fp)
let (sz, poker) = pokeFunc x
encoded = unsafeEncodeWith poker sz
assert (decodeExWith peekFunc encoded == x) $ liftIO $ BS.writeFile (toFilePath fp) encoded
logDebug $ "Finished writing " <> fpt
versionedDecodeOrLoadImpl :: (Store a, Eq a, MonadUnliftIO m, MonadLogger m)
=> (a -> (Int, Poke ()))
-> Peek a
-> Path Abs File
-> m a
-> m a
versionedDecodeOrLoadImpl pokeFunc peekFunc fp mx = do
let fpt = T.pack (toFilePath fp)
logDebug $ "Trying to decode " <> fpt
mres <- versionedDecodeFileImpl peekFunc fp
case mres of
Just x -> do
logDebug $ "Success decoding " <> fpt
return x
_ -> do
logDebug $ "Failure decoding " <> fpt
x <- mx
storeEncodeFile pokeFunc peekFunc fp x
return x
versionedDecodeFileImpl :: (Store a, MonadUnliftIO m, MonadLogger m)
=> Peek a
-> Path loc File
-> m (Maybe a)
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 (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
storeVersionConfig :: String -> String -> VersionConfig a
storeVersionConfig name hash = (namedVersionConfig name hash)
{ vcIgnore = S.fromList
[ "Data.Vector.Unboxed.Base.Vector GHC.Types.Word"
, "Data.ByteString.Internal.ByteString"
]
, vcRenames = M.fromList
[ ( "Data.Maybe.Maybe", "GHC.Base.Maybe")
, ( "Stack.Types.Compiler.CVActual"
, "Stack.Types.Compiler.'CVActual"
)
, ( "Stack.Types.Compiler.CVWanted"
, "Stack.Types.Compiler.'CVWanted"
)
, ( "Data.Map.Internal.Map", "Data.Map.Base.Map")
, ( "Data.Set.Internal.Set", "Data.Set.Base.Set")
]
}