Start implementing commercialhaskell#3006

src/Stack/BuildPlan.hs

@@ -63,6 +63,7 @@ import           Data.Maybe (fromMaybe, mapMaybe, isNothing)
 import           Data.Monoid
 import           Data.Set (Set)
 import qualified Data.Set as Set
+import           Data.Store.Internal (toStaticSizeEx)
 import           Data.Text (Text)
 import qualified Data.Text as T
 import           Data.Text.Encoding (encodeUtf8)
@@ -461,7 +462,7 @@ loadMiniBuildPlan name = do
          -- TODO: store ghc options in BuildPlan?
         , []
         , ppCabalFileInfo pp
-            >>= fmap (GitSHA1 . encodeUtf8)
+            >>= fmap (GitSHA1 . toStaticSizeEx . encodeUtf8)
               . Map.lookup "GitSHA1"
               . cfiHashes
         )

src/Stack/Fetch.hs

@@ -58,6 +58,7 @@ import              Data.Maybe (maybeToList, catMaybes, isJust)
 import              Data.Monoid
 import              Data.Set (Set)
 import qualified    Data.Set as Set
+import              Data.Store.Internal (unStaticSize)
 import qualified    Data.Text as T
 import              Data.Text.Encoding (decodeUtf8)
 import              Data.Text.Metrics
@@ -229,7 +230,7 @@ resolvePackagesAllowMissing mMiniBuildPlan idents0 names0 = do
                     [ "Did not find .cabal file for "
                     , T.pack $ packageIdentifierString $ rpIdent rp
                     , " with SHA of "
-                    , decodeUtf8 sha
+                    , decodeUtf8 $ unStaticSize sha
                     , " in tarball-based cache"
                     ]
 

src/Stack/PackageIndex.hs

@@ -54,6 +54,7 @@ import qualified Data.Map.Strict as Map
 import           Data.Monoid
 import           Data.Set (Set)
 import qualified Data.Set as Set
+import           Data.Store.Internal (toStaticSizeEx)
 import           Data.Store.Version
 import           Data.Store.VersionTagged
 import           Data.Text (Text)
@@ -154,7 +155,7 @@ populateCache index = do
             -- Git algorithm of prepending "blob <size>\0" to the raw
             -- contents. We use this to be able to share the same SHA
             -- information between the Git and tarball backends.
-            gitSHA1 = GitSHA1 $ Mem.convertToBase Mem.Base16 $ hashSHA1 $ L.fromChunks
+            gitSHA1 = GitSHA1 $ toStaticSizeEx $ Mem.convertToBase Mem.Base16 $ hashSHA1 $ L.fromChunks
                 $ "blob "
                 : S8.pack (show $ L.length lbs)
                 : "\0"
@@ -416,7 +417,7 @@ getPackageCaches = do
             result <- liftM mconcat $ forM (configPackageIndices config) $ \index -> do
                 fp <- configPackageIndexCache (indexName index)
                 PackageCacheMap pis' gitPIs <-
-                    $(versionedDecodeOrLoad (storeVersionConfig "pkg-v2" "WlAvAaRXlIMkjSmg5G3dD16UpT8="
+                    $(versionedDecodeOrLoad (storeVersionConfig "pkg-v2" "kxDQIobj5y8zdLDbIP27jdnbbGw="
                                              :: VersionConfig PackageCacheMap))
                     fp
                     (populateCache index)

src/Stack/Types/BuildPlan.hs

@@ -45,7 +45,7 @@ import           Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import           Data.Data
 import qualified Data.HashMap.Strict as HashMap
-import           Data.Hashable (Hashable)
+import           Data.Hashable (Hashable, hashWithSalt)
 import           Data.IntMap (IntMap)
 import qualified Data.IntMap as IntMap
 import           Data.Map (Map)
@@ -54,6 +54,8 @@ import           Data.Maybe (fromMaybe)
 import           Data.Monoid
 import           Data.Set (Set)
 import           Data.Store (Store)
+import           Data.Store.Core
+import           Data.Store.Internal (Size (..), StaticSize (..), size)
 import           Data.Store.Version
 import           Data.Store.VersionTagged
 import           Data.String (IsString, fromString)
@@ -434,7 +436,7 @@ instance Store MiniBuildPlan
 instance NFData MiniBuildPlan
 
 miniBuildPlanVC :: VersionConfig MiniBuildPlan
-miniBuildPlanVC = storeVersionConfig "mbp-v2" "C8q73RrYq3plf9hDCapjWpnm_yc="
+miniBuildPlanVC = storeVersionConfig "mbp-v2" "OO15KiEs7GWoClHuLxvseu36VVo="
 
 -- | Information on a single package for the 'MiniBuildPlan'.
 data MiniPackageInfo = MiniPackageInfo
@@ -460,8 +462,24 @@ data MiniPackageInfo = MiniPackageInfo
 instance Store MiniPackageInfo
 instance NFData MiniPackageInfo
 
-newtype GitSHA1 = GitSHA1 ByteString
-    deriving (Generic, Show, Eq, NFData, Store, Data, Typeable, Ord, Hashable)
+newtype GitSHA1 = GitSHA1 (StaticSize 40 ByteString)
+    deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord)
+
+instance Store GitSHA1 where
+    size = ConstSize 40
+    -- poke (GitSHA1 x) = do
+    --   let (sourceFp, sourceOffset, sourceLength) = BSI.toForeignPtr (unStaticSize x)
+    --   pokeFromForeignPtr sourceFp sourceOffset sourceLength
+    -- peek = do
+    --     let len = 20
+    --     fp <- peekToPlainForeignPtr ("StaticSize " ++ show len ++ " Data.ByteString.ByteString") len
+    --     return (GitSHA1 $ StaticSize (BSI.PS fp 0 len))
+    -- {-# INLINE size #-}
+    -- {-# INLINE peek #-}
+    -- {-# INLINE poke #-}
+
+instance Hashable GitSHA1 where
+  hashWithSalt s (GitSHA1 x) = hashWithSalt s (unStaticSize x)
 
 newtype SnapshotHash = SnapshotHash { unShapshotHash :: ByteString }
     deriving (Generic, Show, Eq)

src/test/Stack/StoreSpec.hs

@@ -16,10 +16,12 @@ import           Data.Int
 import           Data.Map (Map)
 import           Data.Sequences (fromList)
 import           Data.Set (Set)
+import           Data.Store.Internal (StaticSize (..), toStaticSizeEx)
 import           Data.Store.TH
 import           Data.Text (Text)
 import qualified Data.Vector.Unboxed as UV
 import           Data.Word
+import           GHC.TypeLits (KnownNat)
 import           Language.Haskell.TH
 import           Language.Haskell.TH.ReifyMany
 import           Prelude
@@ -51,6 +53,8 @@ instance Monad m => Serial m BS.ByteString where
 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)
+
 addMinAndMaxBounds :: forall a. (Bounded a, Eq a) => [a] -> [a]
 addMinAndMaxBounds xs =
     (if (minBound :: a) `notElem` xs then [minBound] else []) ++