1c8ee99b46
https://prime.haskell.org/wiki/Libraries/Proposals/SemigroupMonoid I am not happy with the fragile pile of CPP boilerplate required to support ghc back to 7.0, which git-annex still targets for both the android build and the standalone build targeting old linux kernels. It makes me unlikely to want to use Semigroup more in git-annex, because the benefit of the abstraction is swamped by the ugliness. I actually considered ripping out all the Semigroup instances, but some are needed to use optparse-applicative. The problem, I think, is they made this transaction on too fast a timeline. (Although ironically, work on it started in 2015 or earlier!) In particular, Debian oldstable is not out of security support, and it's not possible to follow the simpler workarounds documented on the wiki and have it build on oldstable (because the semigroups package in it is too old). I have only tested this build with ghc 8.2.2, not the newer and older versions that branches of the CPP support. So there could be typoes, we'll see. This commit was sponsored by Brock Spratlen on Patreon.
144 lines
4.3 KiB
Haskell
144 lines
4.3 KiB
Haskell
{- git-annex repository differences
|
|
-
|
|
- Copyright 2015 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
module Types.Difference (
|
|
Difference(..),
|
|
Differences(..),
|
|
readDifferences,
|
|
showDifferences,
|
|
getDifferences,
|
|
differenceConfigKey,
|
|
differenceConfigVal,
|
|
hasDifference,
|
|
listDifferences,
|
|
) where
|
|
|
|
import Utility.PartialPrelude
|
|
import qualified Git
|
|
import qualified Git.Config
|
|
|
|
import Data.Maybe
|
|
import Data.Monoid
|
|
import qualified Data.Set as S
|
|
#if MIN_VERSION_base(4,9,0)
|
|
import qualified Data.Semigroup as Sem
|
|
#endif
|
|
import Prelude
|
|
|
|
-- Describes differences from the v5 repository format.
|
|
--
|
|
-- The serialization is stored in difference.log, so avoid changes that
|
|
-- would break compatability.
|
|
--
|
|
-- Not breaking compatability is why a list of Differences is used, rather
|
|
-- than a record type. With a record type, adding a new field for some future
|
|
-- difference would serialize to a value that an older version could not
|
|
-- parse, even if that new field was not used. With the Differences list,
|
|
-- old versions can still parse it, unless the new Difference constructor
|
|
-- is used.
|
|
--
|
|
-- The constructors intentionally do not have parameters; this is to
|
|
-- ensure that any Difference that can be expressed is supported.
|
|
-- So, a new repository version would be Version6, rather than Version Int.
|
|
data Difference
|
|
= ObjectHashLower
|
|
| OneLevelObjectHash
|
|
| OneLevelBranchHash
|
|
deriving (Show, Read, Eq, Ord, Enum, Bounded)
|
|
|
|
-- This type is used internally for efficient checking for differences,
|
|
-- but converted to S.Set Difference for serialization.
|
|
data Differences
|
|
= Differences
|
|
{ objectHashLower :: Bool
|
|
, oneLevelObjectHash :: Bool
|
|
, oneLevelBranchHash :: Bool
|
|
}
|
|
| UnknownDifferences
|
|
|
|
-- UnknownDifferences cannot be equal
|
|
instance Eq Differences where
|
|
UnknownDifferences == _ = False
|
|
_ == UnknownDifferences = False
|
|
a == b = all (\f -> f a == f b)
|
|
[ objectHashLower
|
|
, oneLevelObjectHash
|
|
, oneLevelBranchHash
|
|
]
|
|
|
|
appendDifferences :: Differences -> Differences -> Differences
|
|
appendDifferences a@(Differences {}) b@(Differences {}) = a
|
|
{ objectHashLower = objectHashLower a || objectHashLower b
|
|
, oneLevelObjectHash = oneLevelObjectHash a || oneLevelObjectHash b
|
|
, oneLevelBranchHash = oneLevelBranchHash a || oneLevelBranchHash b
|
|
}
|
|
appendDifferences _ _ = UnknownDifferences
|
|
|
|
#if MIN_VERSION_base(4,9,0)
|
|
instance Sem.Semigroup Differences where
|
|
(<>) = appendDifferences
|
|
#endif
|
|
|
|
instance Monoid Differences where
|
|
mempty = Differences False False False
|
|
#if MIN_VERSION_base(4,11,0)
|
|
#elif MIN_VERSION_base(4,9,0)
|
|
mappend = (Sem.<>)
|
|
#else
|
|
mappend = appendDifferences
|
|
#endif
|
|
|
|
readDifferences :: String -> Differences
|
|
readDifferences = maybe UnknownDifferences mkDifferences . readish
|
|
|
|
showDifferences :: Differences -> String
|
|
showDifferences = show . S.fromList . listDifferences
|
|
|
|
getDifferences :: Git.Repo -> Differences
|
|
getDifferences r = mkDifferences $ S.fromList $
|
|
mapMaybe getmaybe [minBound .. maxBound]
|
|
where
|
|
getmaybe d = case Git.Config.isTrue =<< Git.Config.getMaybe (differenceConfigKey d) r of
|
|
Just True -> Just d
|
|
_ -> Nothing
|
|
|
|
differenceConfigKey :: Difference -> String
|
|
differenceConfigKey ObjectHashLower = tunable "objecthashlower"
|
|
differenceConfigKey OneLevelObjectHash = tunable "objecthash1"
|
|
differenceConfigKey OneLevelBranchHash = tunable "branchhash1"
|
|
|
|
differenceConfigVal :: Difference -> String
|
|
differenceConfigVal _ = Git.Config.boolConfig True
|
|
|
|
tunable :: String -> String
|
|
tunable k = "annex.tune." ++ k
|
|
|
|
hasDifference :: Difference -> Differences -> Bool
|
|
hasDifference _ UnknownDifferences = False
|
|
hasDifference ObjectHashLower ds = objectHashLower ds
|
|
hasDifference OneLevelObjectHash ds = oneLevelObjectHash ds
|
|
hasDifference OneLevelBranchHash ds = oneLevelBranchHash ds
|
|
|
|
listDifferences :: Differences -> [Difference]
|
|
listDifferences d@(Differences {}) = map snd $
|
|
filter (\(f, _) -> f d)
|
|
[ (objectHashLower, ObjectHashLower)
|
|
, (oneLevelObjectHash, OneLevelObjectHash)
|
|
, (oneLevelBranchHash, OneLevelBranchHash)
|
|
]
|
|
listDifferences UnknownDifferences = []
|
|
|
|
mkDifferences :: S.Set Difference -> Differences
|
|
mkDifferences s = Differences
|
|
{ objectHashLower = check ObjectHashLower
|
|
, oneLevelObjectHash = check OneLevelObjectHash
|
|
, oneLevelBranchHash = check OneLevelBranchHash
|
|
}
|
|
where
|
|
check f = f `S.member` s
|