diff --git a/src/Data/Store/VersionTagged.hs b/src/Data/Store/VersionTagged.hs index 27f556750b..160a31fb5e 100644 --- a/src/Data/Store/VersionTagged.hs +++ b/src/Data/Store/VersionTagged.hs @@ -96,6 +96,7 @@ storeVersionConfig name hash = (namedVersionConfig name hash) { vcIgnore = S.fromList [ "Data.Vector.Unboxed.Base.Vector GHC.Types.Word" , "Data.ByteString.Internal.ByteString" + , "Data.ByteString.Short.Internal.ShortByteString" ] , vcRenames = M.fromList [ ( "Data.Maybe.Maybe", "GHC.Base.Maybe") diff --git a/src/Stack/PackageIndex.hs b/src/Stack/PackageIndex.hs index 51437364ab..d203d624fa 100644 --- a/src/Stack/PackageIndex.hs +++ b/src/Stack/PackageIndex.hs @@ -371,7 +371,7 @@ getPackageCaches = do result <- liftM mconcat $ forM (configPackageIndices config) $ \index -> do fp <- configPackageIndexCache (indexName index) PackageCache pis <- - $(versionedDecodeOrLoad (storeVersionConfig "pkg-v5" "PIEH62CpuuOl_fyE25-ncPVZgMU=" + $(versionedDecodeOrLoad (storeVersionConfig "pkg-v6" "XlfP1Sf2cxC0AxuzNyeaP6BqYo4=" :: VersionConfig (PackageCache ()))) fp (populateCache index) diff --git a/src/Stack/Prelude.hs b/src/Stack/Prelude.hs index 96abd2e8d8..22ad02cb90 100644 --- a/src/Stack/Prelude.hs +++ b/src/Stack/Prelude.hs @@ -57,7 +57,7 @@ import Data.Function as X (const, fix, flip, id, on, ($), (&), (.)) import Data.Functor as X (Functor (..), void, ($>), (<$), (<$>)) -import Data.Hashable as X (Hashable) +import Data.Hashable as X (Hashable (hashWithSalt)) import Data.HashMap.Strict as X (HashMap) import Data.HashSet as X (HashSet) import Data.Int as X diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index 2008ad607d..f743e3c111 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -283,7 +283,7 @@ instance Store LoadedSnapshot instance NFData LoadedSnapshot loadedSnapshotVC :: VersionConfig LoadedSnapshot -loadedSnapshotVC = storeVersionConfig "ls-v4" "UQQmEqSZneE0IrDjeIy_uvDkhvM=" +loadedSnapshotVC = storeVersionConfig "ls-v5" "1sKfCC3azJist4Wb_Gy_X0Z6y48=" -- | Information on a single package for the 'LoadedSnapshot' which -- can be installed. diff --git a/src/Stack/Types/FlagName.hs b/src/Stack/Types/FlagName.hs index 4ed38e8cf7..27fa0bcfb0 100644 --- a/src/Stack/Types/FlagName.hs +++ b/src/Stack/Types/FlagName.hs @@ -27,6 +27,7 @@ import Data.Aeson.Extended import Data.Attoparsec.Combinators import Data.Attoparsec.Text import Data.Char (isLetter, isDigit, toLower) +import Data.Store (Store (..), Size (..)) import qualified Data.Text as T import qualified Distribution.PackageDescription as Cabal import Language.Haskell.TH @@ -41,22 +42,36 @@ instance Show FlagNameParseFail where show (FlagNameParseFail bs) = "Invalid flag name: " ++ show bs -- | A flag name. -newtype FlagName = - FlagName Text - deriving (Typeable,Data,Generic,Hashable,Store,NFData,ToJSONKey) +newtype FlagName = FlagName Cabal.FlagName + deriving (Typeable,Data,Generic) instance Eq FlagName where x == y = compare x y == EQ instance Ord FlagName where - compare (FlagName x) (FlagName y) = - compare (T.map toLower x) (T.map toLower y) + compare x y = compare + (map toLower (flagNameString x)) + (map toLower (flagNameString y)) +instance Hashable FlagName where + hashWithSalt x y = hashWithSalt x (flagNameString y) +instance Store FlagName where + size = -- could use contramap instead... + case size of + VarSize f -> VarSize (f . flagNameString) + ConstSize x -> assert False (ConstSize x) + poke = poke . flagNameString + peek = (FlagName . Cabal.mkFlagName) <$> peek +instance NFData FlagName where + rnf = rnf . flagNameString +instance ToJSON FlagName where + toJSON = toJSON . flagNameString +instance ToJSONKey FlagName instance Lift FlagName where - lift (FlagName n) = + lift n = appE (conE 'FlagName) - (stringE (T.unpack n)) + (stringE (flagNameString n)) instance Show FlagName where - show (FlagName n) = T.unpack n + show = flagNameString instance FromJSON FlagName where parseJSON j = @@ -73,7 +88,7 @@ instance FromJSONKey FlagName where -- | Attoparsec parser for a flag name flagNameParser :: Parser FlagName flagNameParser = - fmap (FlagName . T.pack) + fmap (FlagName . Cabal.mkFlagName) (appending (many1 (satisfy isLetter)) (concating (many (alternating (pured (satisfy isAlphaNum)) @@ -103,20 +118,16 @@ parseFlagNameFromString = -- | Produce a string representation of a flag name. flagNameString :: FlagName -> String -flagNameString (FlagName n) = T.unpack n +flagNameString (FlagName n) = Cabal.unFlagName n -- | Produce a string representation of a flag name. flagNameText :: FlagName -> Text -flagNameText (FlagName n) = n +flagNameText = T.pack . flagNameString -- | Convert from a Cabal flag name. fromCabalFlagName :: Cabal.FlagName -> FlagName -fromCabalFlagName name = - let !x = T.pack $ Cabal.unFlagName name - in FlagName x +fromCabalFlagName = FlagName -- | Convert to a Cabal flag name. toCabalFlagName :: FlagName -> Cabal.FlagName -toCabalFlagName (FlagName name) = - let !x = T.unpack name - in Cabal.mkFlagName x +toCabalFlagName (FlagName name) = name diff --git a/src/Stack/Types/GhcPkgId.hs b/src/Stack/Types/GhcPkgId.hs index 791e8765ca..34c76492ec 100644 --- a/src/Stack/Types/GhcPkgId.hs +++ b/src/Stack/Types/GhcPkgId.hs @@ -27,7 +27,7 @@ instance Show GhcPkgIdParseFail where instance Exception GhcPkgIdParseFail -- | A ghc-pkg package identifier. -newtype GhcPkgId = GhcPkgId Text +newtype GhcPkgId = GhcPkgId Text -- TODO consider using ShortText or ShortByteString here deriving (Eq,Ord,Data,Typeable,Generic) instance Hashable GhcPkgId diff --git a/src/Stack/Types/PackageDump.hs b/src/Stack/Types/PackageDump.hs index 8e96ad1387..c658f3ca78 100644 --- a/src/Stack/Types/PackageDump.hs +++ b/src/Stack/Types/PackageDump.hs @@ -31,4 +31,6 @@ data InstalledCacheEntry = InstalledCacheEntry instance Store InstalledCacheEntry installedCacheVC :: VersionConfig InstalledCacheInner -installedCacheVC = storeVersionConfig "installed-v1" "GGyaE6qY9FOqeWtozuadKqS7_QM=" +-- FIXME would be really nice to avoid changing this hash... +--installedCacheVC = storeVersionConfig "installed-v1" "GGyaE6qY9FOqeWtozuadKqS7_QM=" +installedCacheVC = storeVersionConfig "installed-v2" "SOd6CFM7HnrOCwfIBdh-iHNypH4=" diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs index eaf703e5cf..340267f2e3 100644 --- a/src/Stack/Types/PackageIdentifier.hs +++ b/src/Stack/Types/PackageIdentifier.hs @@ -43,7 +43,6 @@ import Data.Aeson.Extended import Data.Attoparsec.Text as A import qualified Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16)) import qualified Data.ByteString.Lazy as L -import Data.Hashable import Data.Store.Internal (Size (..), StaticSize (..), size, toStaticSize, toStaticSizeEx, unStaticSize) import qualified Data.Text as T diff --git a/src/Stack/Types/PackageName.hs b/src/Stack/Types/PackageName.hs index e31fe19c78..c2dfa48d38 100644 --- a/src/Stack/Types/PackageName.hs +++ b/src/Stack/Types/PackageName.hs @@ -29,6 +29,7 @@ import Data.Aeson.Extended import Data.Attoparsec.Combinators import Data.Attoparsec.Text import Data.List (intercalate) +import Data.Store (Store (..), Size (..)) import qualified Data.Text as T import qualified Distribution.Package as Cabal import Language.Haskell.TH @@ -49,17 +50,29 @@ instance Show PackageNameParseFail where show (CabalFileNameInvalidPackageName fp) = "cabal file names must use valid package names followed by a .cabal extension, the following is invalid: " ++ fp -- | A package name. -newtype PackageName = - PackageName Text - deriving (Eq,Ord,Typeable,Data,Generic,Hashable,NFData,Store,ToJSON,ToJSONKey) +newtype PackageName = PackageName Cabal.PackageName + deriving (Eq,Ord,Typeable,Data,Generic,NFData) + +instance Hashable PackageName where + hashWithSalt x y = hashWithSalt x (packageNameString y) +instance Store PackageName where + size = + case size of + VarSize f -> VarSize (f . packageNameString) + ConstSize x -> assert False (ConstSize x) + poke = poke . packageNameString + peek = (PackageName . Cabal.mkPackageName) <$> peek +instance ToJSON PackageName where + toJSON = toJSON . packageNameString +instance ToJSONKey PackageName instance Lift PackageName where lift (PackageName n) = appE (conE 'PackageName) - (stringE (T.unpack n)) + (stringE (Cabal.unPackageName n)) instance Show PackageName where - show (PackageName n) = T.unpack n + show (PackageName n) = Cabal.unPackageName n instance FromJSON PackageName where parseJSON j = @@ -76,7 +89,7 @@ instance FromJSONKey PackageName where -- | Attoparsec parser for a package name packageNameParser :: Parser PackageName packageNameParser = - fmap (PackageName . T.pack . intercalate "-") + fmap (PackageName . Cabal.mkPackageName . intercalate "-") (sepBy1 word (char '-')) where word = concat <$> sequence [many digit, @@ -104,23 +117,19 @@ parsePackageNameFromString = -- | Produce a string representation of a package name. packageNameString :: PackageName -> String -packageNameString (PackageName n) = T.unpack n +packageNameString (PackageName n) = Cabal.unPackageName n -- | Produce a string representation of a package name. packageNameText :: PackageName -> Text -packageNameText (PackageName n) = n +packageNameText = T.pack . packageNameString -- | Convert from a Cabal package name. fromCabalPackageName :: Cabal.PackageName -> PackageName -fromCabalPackageName name = - let !x = T.pack $ Cabal.unPackageName name - in PackageName x +fromCabalPackageName = PackageName -- | Convert to a Cabal package name. toCabalPackageName :: PackageName -> Cabal.PackageName -toCabalPackageName (PackageName name) = - let !x = T.unpack name - in Cabal.mkPackageName x +toCabalPackageName (PackageName name) = name -- | Parse a package name from a file path. parsePackageNameFromFilePath :: MonadThrow m => Path a File -> m PackageName diff --git a/src/Stack/Types/Version.hs b/src/Stack/Types/Version.hs index d2e4ba441e..0299fa63dd 100644 --- a/src/Stack/Types/Version.hs +++ b/src/Stack/Types/Version.hs @@ -6,6 +6,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ViewPatterns #-} -- | Versions for packages. @@ -34,13 +35,12 @@ module Stack.Types.Version import Stack.Prelude hiding (Vector) import Data.Aeson.Extended -import Data.Attoparsec.Text +import Data.Attoparsec.Text hiding (take) import Data.Hashable (Hashable (..)) import Data.List import qualified Data.Set as Set +import Data.Store (Store (..), Size (..)) import qualified Data.Text as T -import Data.Vector.Unboxed (Vector) -import qualified Data.Vector.Unboxed as V import Distribution.Text (disp) import qualified Distribution.Version as Cabal import Language.Haskell.TH @@ -59,24 +59,31 @@ instance Show VersionParseFail where data UpgradeTo = Specific Version | Latest deriving (Show) -- | A package version. -newtype Version = - Version {unVersion :: Vector Word} - deriving (Eq,Ord,Typeable,Data,Generic,Store,NFData) +newtype Version = Version Cabal.Version + deriving (Eq,Ord,Typeable,Data,Generic,NFData) instance Hashable Version where - hashWithSalt i = hashWithSalt i . V.toList . unVersion + hashWithSalt i (Version v) = hashWithSalt i $ Cabal.versionNumbers v + +instance Store Version where + size = + case size of + VarSize f -> VarSize (f . Cabal.versionNumbers . toCabalVersion) + ConstSize x -> assert False (ConstSize x) + poke = poke . Cabal.versionNumbers . toCabalVersion + peek = (fromCabalVersion . Cabal.mkVersion) <$> peek instance Lift Version where lift (Version n) = appE (conE 'Version) - (appE (varE 'V.fromList) + (appE (varE 'Cabal.mkVersion) (listE (map (litE . IntegerL . fromIntegral) - (V.toList n)))) + (Cabal.versionNumbers n)))) instance Show Version where show (Version v) = intercalate "." - (map show (V.toList v)) + (map show (Cabal.versionNumbers v)) instance ToJSON Version where toJSON = toJSON . versionText @@ -104,7 +111,7 @@ instance Monoid IntersectingVersionRange where versionParser :: Parser Version versionParser = do ls <- (:) <$> num <*> many num' - let !v = V.fromList ls + let !v = Cabal.mkVersion ls return (Version v) where num = decimal num' = point *> num @@ -126,7 +133,7 @@ parseVersionFromString = versionString :: Version -> String versionString (Version v) = intercalate "." - (map show (V.toList v)) + (map show (Cabal.versionNumbers v)) -- | Get a string representation of a package version. versionText :: Version -> Text @@ -134,18 +141,15 @@ versionText (Version v) = T.intercalate "." (map (T.pack . show) - (V.toList v)) + (Cabal.versionNumbers v)) -- | Convert to a Cabal version. toCabalVersion :: Version -> Cabal.Version -toCabalVersion (Version v) = - Cabal.mkVersion (map fromIntegral (V.toList v)) +toCabalVersion (Version v) = v -- | Convert from a Cabal version. fromCabalVersion :: Cabal.Version -> Version -fromCabalVersion vs = - let !v = V.fromList (map fromIntegral (Cabal.versionNumbers vs)) - in Version v +fromCabalVersion = Version -- | Make a package version. mkVersion :: String -> Q Exp @@ -169,10 +173,11 @@ intersectVersionRanges x y = Cabal.simplifyVersionRange $ Cabal.intersectVersion -- | Returns the first two components, defaulting to 0 if not present toMajorVersion :: Version -> Version toMajorVersion (Version v) = - case V.length v of - 0 -> Version (V.fromList [0, 0]) - 1 -> Version (V.fromList [V.head v, 0]) - _ -> Version (V.fromList [V.head v, v V.! 1]) + Version . Cabal.mkVersion $ + case Cabal.versionNumbers v of + [] -> [0, 0] + [x] -> [x, 0] + x:y:_ -> [x, y] -- | Given a version range and a set of versions, find the latest version from -- the set that is within the range. @@ -182,10 +187,11 @@ latestApplicableVersion r = listToMaybe . filter (`withinRange` r) . Set.toDescL -- | Get the next major version number for the given version nextMajorVersion :: Version -> Version nextMajorVersion (Version v) = - case V.length v of - 0 -> Version (V.fromList [0, 1]) - 1 -> Version (V.fromList [V.head v, 1]) - _ -> Version (V.fromList [V.head v, (v V.! 1) + 1]) + Version . Cabal.mkVersion $ + case Cabal.versionNumbers v of + [] -> [0, 1] + [x] -> [x, 1] + x:y:_ -> [x, y + 1] data VersionCheck = MatchMinor @@ -207,15 +213,20 @@ instance FromJSON VersionCheck where expected = "VersionCheck value (match-minor, match-exact, or newer-minor)" checkVersion :: VersionCheck -> Version -> Version -> Bool -checkVersion check (Version wanted) (Version actual) = +checkVersion check (Version (Cabal.versionNumbers -> wanted)) (Version (Cabal.versionNumbers -> actual)) = case check of - MatchMinor -> V.and (V.take 3 matching) - MatchExact -> V.length wanted == V.length actual && V.and matching - NewerMinor -> V.and (V.take 2 matching) && newerMinor + MatchMinor -> and (take 3 matching) + MatchExact -> length wanted == length actual && and matching + NewerMinor -> and (take 2 matching) && newerMinor where - matching = V.zipWith (==) wanted actual + matching = zipWith (==) wanted actual newerMinor = - case (wanted V.!? 2, actual V.!? 2) of + case (wanted !? 2, actual !? 2) of (Nothing, _) -> True (Just _, Nothing) -> False (Just w, Just a) -> a >= w + + (!?) :: [a] -> Int -> Maybe a + [] !? _ = Nothing + (x:_) !? 0 = Just x + (_:xs) !? i = xs !? (i - 1) diff --git a/src/test/Stack/StoreSpec.hs b/src/test/Stack/StoreSpec.hs index 72534b4470..16b84d370a 100644 --- a/src/test/Stack/StoreSpec.hs +++ b/src/test/Stack/StoreSpec.hs @@ -9,6 +9,7 @@ module Stack.StoreSpec where import qualified Data.ByteString as BS +import Data.ByteString.Short (ShortByteString, toShort) import Data.Containers (mapFromList, setFromList) import Data.Sequences (fromList) import Data.Store.Internal (StaticSize (..)) @@ -45,6 +46,8 @@ instance (Monad m, Serial m a, Ord a) => Serial m (Set a) where series = fmap setFromList series instance (Monad m, KnownNat n) => Serial m (StaticSize n BS.ByteString) +instance Monad m => Serial m ShortByteString where + series = fmap toShort series addMinAndMaxBounds :: forall a. (Bounded a, Eq a) => [a] -> [a] addMinAndMaxBounds xs = @@ -63,7 +66,8 @@ $(do let tys = [ ''InstalledCacheInner , ''BuildCache , ''ConfigCache ] - ns <- reifyManyWithoutInstances ''Serial tys (`notElem` [''UV.Vector]) + ns <- reifyManyWithoutInstances ''Serial tys + (`notElem` [''UV.Vector, ''ShortByteString]) let f n = [d| instance Monad m => Serial m $(conT n) |] concat <$> mapM f ns)