Commit 09865f60 authored by Edward Z. Yang's avatar Edward Z. Yang
Browse files

Revert "Handle undefined MIN_VERSION_base in Distribution.Utils.BinaryWithFingerprint"

This reverts commit eca045bc.

Revert "Add fingerprint of Generic representation when serializing."

This reverts commit ebcae71d.
parent 369a8c2e
......@@ -239,7 +239,6 @@ library
Distribution.Utils.NubList
Distribution.Utils.ShortText
Distribution.Utils.Progress
Distribution.Utils.BinaryWithFingerprint
Distribution.Verbosity
Distribution.Version
Language.Haskell.Extension
......
......@@ -110,7 +110,7 @@ import qualified Distribution.Simple.HaskellSuite as HaskellSuite
import Control.Exception
( ErrorCall, Exception, evaluate, throw, throwIO, try )
import Distribution.Utils.BinaryWithFingerprint
import Distribution.Compat.Binary ( decodeOrFailIO, encode )
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy.Char8 as BLC8
......@@ -199,7 +199,7 @@ getConfigStateFile filename = do
Right x -> x
let getStoredValue = do
result <- decodeWithFingerprintOrFailIO (BLC8.tail body)
result <- decodeOrFailIO (BLC8.tail body)
case result of
Left _ -> throw ConfigStateFileNoParse
Right x -> return x
......@@ -244,7 +244,7 @@ writePersistBuildConfig :: FilePath -- ^ The @dist@ directory path.
writePersistBuildConfig distPref lbi = do
createDirectoryIfMissing False distPref
writeFileAtomic (localBuildInfoFile distPref) $
BLC8.unlines [showHeader pkgId, encodeWithFingerprint lbi]
BLC8.unlines [showHeader pkgId, encode lbi]
where
pkgId = localPackage lbi
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
-- | Support for binary serialization with a fingerprint.
module Distribution.Utils.BinaryWithFingerprint (
encodeWithFingerprint,
decodeWithFingerprint,
decodeWithFingerprintOrFailIO,
) where
#ifdef MIN_VERSION_base
#define MINVER_base_48 MIN_VERSION_base(4,8,0)
#else
#define MINVER_base_48 (__GLASGOW_HASKELL__ >= 710)
#endif
#if MINVER_base_48
import Distribution.Compat.Binary
import Data.ByteString.Lazy (ByteString)
import Control.Exception
import Data.Binary.Get
import Data.Binary.Put
import GHC.Generics
import GHC.Fingerprint
import Data.Typeable
import Control.Monad
-- | Private wrapper type so we can give 'Binary' instance for
-- 'Fingerprint'
newtype FP = FP Fingerprint
instance Binary FP where
put (FP (Fingerprint a b)) = put a >> put b
get = do
a <- get
b <- get
return (FP (Fingerprint a b))
fingerprintRep :: forall a. Typeable (Rep a) => Proxy a -> Fingerprint
fingerprintRep _ = typeRepFingerprint (typeRep (Proxy :: Proxy (Rep a)))
-- | Encode a value, recording a fingerprint in the header.
--
-- The fingerprint is GHC's Typeable fingerprint associated with
-- the Generic Rep of a type: this fingerprint is better than
-- the fingerprint of the type itself, as it changes when the
-- representation changes (and thus the binary serialization format
-- changes.)
--
encodeWithFingerprint :: forall a. (Binary a, Typeable (Rep a)) => a -> ByteString
encodeWithFingerprint x = runPut $ do
put (FP (fingerprintRep (Proxy :: Proxy a)))
put x
-- | Decode a value, verifying the fingerprint in the header.
--
decodeWithFingerprint :: forall a. (Binary a, Typeable (Rep a)) => ByteString -> a
decodeWithFingerprint = runGet $ do
FP fp <- get
let expect_fp = fingerprintRep (Proxy :: Proxy a)
when (expect_fp /= fp) $
fail $ "Expected fingerprint " ++ show expect_fp ++
" but got " ++ show fp
get
-- | Decode a value, forcing the decoded value to discover decoding errors
-- and report them.
--
decodeWithFingerprintOrFailIO :: (Binary a, Typeable (Rep a)) => ByteString -> IO (Either String a)
decodeWithFingerprintOrFailIO bs =
catch (evaluate (decodeWithFingerprint bs) >>= return . Right)
$ \(ErrorCall str) -> return $ Left str
#else
import Distribution.Compat.Binary
import Data.ByteString.Lazy (ByteString)
-- Dummy implementations that don't actually save fingerprints
encodeWithFingerprint :: Binary a => a -> ByteString
encodeWithFingerprint = encode
decodeWithFingerprint :: Binary a => ByteString -> a
decodeWithFingerprint = decode
decodeWithFingerprintOrFailIO :: Binary a => ByteString -> IO (Either String a)
decodeWithFingerprintOrFailIO = decodeOrFailIO
#endif
......@@ -45,7 +45,7 @@ import qualified Data.Map.Strict as Map
import qualified Data.Map as Map
#endif
import qualified Data.ByteString.Lazy as BS
import qualified Distribution.Utils.BinaryWithFingerprint as Binary
import qualified Distribution.Compat.Binary as Binary
import qualified Data.Hashable as Hashable
import Control.Monad
......@@ -403,7 +403,7 @@ data MonitorChangedReason a =
-- See 'FileMonitor' for a full explanation.
--
checkFileMonitorChanged
:: (Binary a, Binary b, Typeable a, Typeable b)
:: (Binary a, Binary b)
=> FileMonitor a b -- ^ cache file path
-> FilePath -- ^ root directory
-> a -- ^ guard or key value
......@@ -481,23 +481,23 @@ checkFileMonitorChanged
--
-- This determines the type and format of the binary cache file.
--
readCacheFile :: (Binary a, Binary b, Typeable a, Typeable b)
readCacheFile :: (Binary a, Binary b)
=> FileMonitor a b
-> IO (Either String (MonitorStateFileSet, a, b))
readCacheFile FileMonitor {fileMonitorCacheFile} =
withBinaryFile fileMonitorCacheFile ReadMode $ \hnd ->
Binary.decodeWithFingerprintOrFailIO =<< BS.hGetContents hnd
Binary.decodeOrFailIO =<< BS.hGetContents hnd
-- | Helper for writing the cache file.
--
-- This determines the type and format of the binary cache file.
--
rewriteCacheFile :: (Binary a, Binary b, Typeable a, Typeable b)
rewriteCacheFile :: (Binary a, Binary b)
=> FileMonitor a b
-> MonitorStateFileSet -> a -> b -> IO ()
rewriteCacheFile FileMonitor {fileMonitorCacheFile} fileset key result =
writeFileAtomic fileMonitorCacheFile $
Binary.encodeWithFingerprint (fileset, key, result)
Binary.encode (fileset, key, result)
-- | Probe the file system to see if any of the monitored files have changed.
--
......@@ -758,7 +758,7 @@ probeMonitorStateGlobRel _ _ _ _ MonitorStateGlobDirTrailing =
-- any files then you can use @Nothing@ for the timestamp parameter.
--
updateFileMonitor
:: (Binary a, Binary b, Typeable a, Typeable b)
:: (Binary a, Binary b)
=> FileMonitor a b -- ^ cache file path
-> FilePath -- ^ root directory
-> Maybe MonitorTimestamp -- ^ timestamp when the update action started
......@@ -965,7 +965,7 @@ getFileHash hashcache relfile absfile mtime =
-- that the set of files to monitor can change then it's simpler just to throw
-- away the structure and use a finite map.
--
readCacheFileHashes :: (Binary a, Binary b, Typeable a, Typeable b)
readCacheFileHashes :: (Binary a, Binary b)
=> FileMonitor a b -> IO FileHashCache
readCacheFileHashes monitor =
handleDoesNotExist Map.empty $
......
{-# LANGUAGE BangPatterns, RecordWildCards, NamedFieldPuns,
DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving,
ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Distribution.Client.ProjectPlanOutput (
-- * Plan output
......@@ -43,7 +41,6 @@ import Distribution.Text
import qualified Distribution.Compat.Graph as Graph
import Distribution.Compat.Graph (Graph, Node)
import qualified Distribution.Compat.Binary as Binary
import qualified Distribution.Utils.BinaryWithFingerprint as Binary
import Distribution.Simple.Utils
import Distribution.Verbosity
import qualified Paths_cabal_install as Our (version)
......@@ -56,7 +53,6 @@ import qualified Data.Set as Set
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Builder as BB
import GHC.Generics
import System.FilePath
import System.IO
......@@ -328,15 +324,6 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
type PackageIdSet = Set UnitId
type PackagesUpToDate = PackageIdSet
newtype PackagesUpToDateG = PackagesUpToDateG { unPackagesUpToDateG :: PackagesUpToDate }
instance Binary.Binary PackagesUpToDateG
instance Generic PackagesUpToDateG where
type Rep PackagesUpToDateG = Rep [UnitId]
from = from . Set.toList . unPackagesUpToDateG
to = PackagesUpToDateG . Set.fromList . to
data PostBuildProjectStatus = PostBuildProjectStatus {
-- | Packages that are known to be up to date. These were found to be
......@@ -655,8 +642,7 @@ readPackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} =
handleDoesNotExist Set.empty $
handleDecodeFailure $
withBinaryFile (distProjectCacheFile "up-to-date") ReadMode $ \hnd ->
fmap (fmap unPackagesUpToDateG) .
Binary.decodeWithFingerprintOrFailIO =<< BS.hGetContents hnd
Binary.decodeOrFailIO =<< BS.hGetContents hnd
where
handleDecodeFailure = fmap (either (const Set.empty) id)
......@@ -667,7 +653,7 @@ readPackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} =
writePackagesUpToDateCacheFile :: DistDirLayout -> PackagesUpToDate -> IO ()
writePackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} upToDate =
writeFileAtomic (distProjectCacheFile "up-to-date") $
Binary.encodeWithFingerprint (PackagesUpToDateG upToDate)
Binary.encode upToDate
-- Writing .ghc.environment files
--
......
......@@ -112,7 +112,7 @@ askRoot = Rebuild Reader.ask
--
-- Do not share 'FileMonitor's between different uses of 'rerunIfChanged'.
--
rerunIfChanged :: (Binary a, Binary b, Typeable a, Typeable b)
rerunIfChanged :: (Binary a, Binary b)
=> Verbosity
-> FileMonitor a b
-> a
......
module UnitTests.Distribution.Client.FileMonitor (tests) where
import Data.Typeable
import Control.Monad
import Control.Exception
import Control.Concurrent (threadDelay)
......@@ -812,7 +811,7 @@ monitorFileGlobStr globstr
| otherwise = error $ "Failed to parse " ++ globstr
expectMonitorChanged :: (Binary a, Binary b, Typeable a, Typeable b)
expectMonitorChanged :: (Binary a, Binary b)
=> RootPath -> FileMonitor a b -> a
-> IO (MonitorChangedReason a)
expectMonitorChanged root monitor key = do
......@@ -821,7 +820,7 @@ expectMonitorChanged root monitor key = do
MonitorChanged reason -> return reason
MonitorUnchanged _ _ -> throwIO $ HUnitFailure "expected change"
expectMonitorUnchanged :: (Binary a, Binary b, Typeable a, Typeable b)
expectMonitorUnchanged :: (Binary a, Binary b)
=> RootPath -> FileMonitor a b -> a
-> IO (b, [MonitorFilePath])
expectMonitorUnchanged root monitor key = do
......@@ -830,19 +829,19 @@ expectMonitorUnchanged root monitor key = do
MonitorChanged _reason -> throwIO $ HUnitFailure "expected no change"
MonitorUnchanged b files -> return (b, files)
checkChanged :: (Binary a, Binary b, Typeable a, Typeable b)
checkChanged :: (Binary a, Binary b)
=> RootPath -> FileMonitor a b
-> a -> IO (MonitorChanged a b)
checkChanged (RootPath root) monitor key =
checkFileMonitorChanged monitor root key
updateMonitor :: (Binary a, Binary b, Typeable a, Typeable b)
updateMonitor :: (Binary a, Binary b)
=> RootPath -> FileMonitor a b
-> [MonitorFilePath] -> a -> b -> IO ()
updateMonitor (RootPath root) monitor files key result =
updateFileMonitor monitor root Nothing files key result
updateMonitorWithTimestamp :: (Binary a, Binary b, Typeable a, Typeable b)
updateMonitorWithTimestamp :: (Binary a, Binary b)
=> RootPath -> FileMonitor a b -> MonitorTimestamp
-> [MonitorFilePath] -> a -> b -> IO ()
updateMonitorWithTimestamp (RootPath root) monitor timestamp files key result =
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment