{-# LANGUAGE ScopedTypeVariables, RecordWildCards, FlexibleInstances #-}
{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-}
module Development.Shake.Internal.Core.Storage(
usingStorage
) where
import General.Chunks
import General.Cleanup
import General.Binary
import General.Intern
import Development.Shake.Internal.Options
import Development.Shake.Internal.Errors
import General.Timing
import General.FileLock
import qualified General.Ids as Ids
import Control.Exception.Extra
import Control.Monad.Extra
import Data.Monoid
import Data.Either.Extra
import Data.Time
import Data.Char
import Data.Word
import System.Info
import Development.Shake.Classes
import Numeric
import General.Extra
import Data.List.Extra
import Data.Maybe
import System.FilePath
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.HashMap.Strict as Map
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString as BS8
import Prelude
databaseVersion :: String -> String
databaseVersion :: String -> String
databaseVersion x :: String
x = "SHAKE-DATABASE-14-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
os String -> String -> String
forall a. [a] -> [a] -> [a]
++ "-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
arch String -> String -> String
forall a. [a] -> [a] -> [a]
++ "-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\r\n"
where s :: String
s = String -> String
forall a. [a] -> [a]
tail (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
init (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. Show a => a -> String
show String
x
messageCorrupt :: FilePath -> SomeException -> IO [String]
messageCorrupt :: String -> SomeException -> IO [String]
messageCorrupt dbfile :: String
dbfile err :: SomeException
err = do
String
msg <- SomeException -> IO String
forall e. Show e => e -> IO String
showException SomeException
err
[String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$
("Error when reading Shake database " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dbfile) String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
(String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (" "String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> [String]
lines String
msg) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
["All files will be rebuilt"]
messageDatabaseVersionChange :: FilePath -> BS.ByteString -> BS.ByteString -> [String]
messageDatabaseVersionChange :: String -> ByteString -> ByteString -> [String]
messageDatabaseVersionChange dbfile :: String
dbfile old :: ByteString
old new :: ByteString
new =
["Shake database version changed (either shake library version, or shakeVersion):"
," File: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dbfile
," Old version: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
disp (String -> String
limit (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BS.unpack ByteString
old)
," New version: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
disp (ByteString -> String
BS.unpack ByteString
new)
,"All rules will be rebuilt"]
where
limit :: String -> String
limit x :: String
x = let (a :: String
a,b :: String
b) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt 200 String
x in String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
b then "" else "...")
disp :: String -> String
disp = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (\x :: Char
x -> if Char -> Bool
isPrint Char
x Bool -> Bool -> Bool
&& Char -> Bool
isAscii Char
x then Char
x else '?') (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ("\r\n" :: String))
messageMissingTypes :: FilePath -> [String] -> [String]
messageMissingTypes :: String -> [String] -> [String]
messageMissingTypes dbfile :: String
dbfile types :: [String]
types =
["Shake database rules have changed for the following types:"
," File: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dbfile] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
[" Type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x | String
x <- [String]
types] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
["All rules using these types will be rebuilt"]
usingStorage
:: (Show k, Eq k, Hashable k, NFData k, Show v, NFData v)
=> Cleanup
-> ShakeOptions
-> (IO String -> IO ())
-> Map.HashMap k (Ver, BinaryOp v)
-> IO (Ids.Ids v, k -> Id -> v -> IO ())
usingStorage :: Cleanup
-> ShakeOptions
-> (IO String -> IO ())
-> HashMap k (Ver, BinaryOp v)
-> IO (Ids v, k -> Id -> v -> IO ())
usingStorage _ ShakeOptions{..} diagnostic :: IO String -> IO ()
diagnostic _ | String
shakeFiles String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "/dev/null" = do
IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure "Using in-memory database"
Ids v
ids <- IO (Ids v)
forall a. IO (Ids a)
Ids.empty
(Ids v, k -> Id -> v -> IO ()) -> IO (Ids v, k -> Id -> v -> IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ids v
ids, \_ _ _ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
usingStorage cleanup :: Cleanup
cleanup ShakeOptions{..} diagnostic :: IO String -> IO ()
diagnostic witness :: HashMap k (Ver, BinaryOp v)
witness = do
let lockFile :: String
lockFile = String
shakeFiles String -> String -> String
</> ".shake.lock"
IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ "Before usingLockFile on " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lockFile
Cleanup -> String -> IO ()
usingLockFile Cleanup
cleanup String
lockFile
IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure "After usingLockFile"
let dbfile :: String
dbfile = String
shakeFiles String -> String -> String
</> ".shake.database"
String -> IO ()
createDirectoryRecursive String
shakeFiles
IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (String -> IO Bool
restoreChunksBackup String
dbfile) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
unexpected "Backup file exists, restoring over the previous file\n"
IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure "Backup file move to original"
String -> IO ()
addTiming "Database read"
Chunks
h <- Cleanup -> String -> Maybe Seconds -> IO Chunks
usingChunks Cleanup
cleanup String
dbfile Maybe Seconds
shakeFlush
let corrupt :: IO ()
corrupt
| Bool -> Bool
not Bool
shakeStorageLog = Maybe String -> Chunks -> IO ()
resetChunksCorrupt Maybe String
forall a. Maybe a
Nothing Chunks
h
| Bool
otherwise = do
let file :: String
file = String
dbfile String -> String -> String
<.> "corrupt"
Maybe String -> Chunks -> IO ()
resetChunksCorrupt (String -> Maybe String
forall a. a -> Maybe a
Just String
file) Chunks
h
String -> IO ()
unexpected (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Backup of corrupted file stored at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n"
let ver :: ByteString
ver = String -> ByteString
BS.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> String
databaseVersion String
shakeVersion
Either ByteString ByteString
oldVer <- Chunks -> Word32 -> IO (Either ByteString ByteString)
readChunkMax Chunks
h (Word32 -> IO (Either ByteString ByteString))
-> Word32 -> IO (Either ByteString ByteString)
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
ver Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 100000
let verEq :: Bool
verEq = ByteString -> Either ByteString ByteString
forall a b. b -> Either a b
Right ByteString
ver Either ByteString ByteString
-> Either ByteString ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Either ByteString ByteString
oldVer
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
shakeVersionIgnore Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
verEq Bool -> Bool -> Bool
&& Either ByteString ByteString
oldVer Either ByteString ByteString
-> Either ByteString ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString -> Either ByteString ByteString
forall a b. a -> Either a b
Left ByteString
BS.empty) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[String] -> IO ()
outputErr ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> ByteString -> [String]
messageDatabaseVersionChange String
dbfile (Either ByteString ByteString -> ByteString
forall a. Either a a -> a
fromEither Either ByteString ByteString
oldVer) ByteString
ver
IO ()
corrupt
(!ByteString
witnessNew, !k -> Id -> v -> Builder
save) <- (ByteString, k -> Id -> v -> Builder)
-> IO (ByteString, k -> Id -> v -> Builder)
forall a. a -> IO a
evaluate ((ByteString, k -> Id -> v -> Builder)
-> IO (ByteString, k -> Id -> v -> Builder))
-> (ByteString, k -> Id -> v -> Builder)
-> IO (ByteString, k -> Id -> v -> Builder)
forall a b. (a -> b) -> a -> b
$ HashMap k (Ver, BinaryOp v)
-> (ByteString, k -> Id -> v -> Builder)
forall k v.
(Eq k, Hashable k, Show k) =>
HashMap k (Ver, BinaryOp v)
-> (ByteString, k -> Id -> v -> Builder)
saveWitness HashMap k (Ver, BinaryOp v)
witness
Either ByteString ByteString
witnessOld <- Chunks -> IO (Either ByteString ByteString)
readChunk Chunks
h
Maybe (Ids v)
ids <- case Either ByteString ByteString
witnessOld of
Left _ -> do
Maybe String -> Chunks -> IO ()
resetChunksCorrupt Maybe String
forall a. Maybe a
Nothing Chunks
h
Maybe (Ids v) -> IO (Maybe (Ids v))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Ids v)
forall a. Maybe a
Nothing
Right witnessOld :: ByteString
witnessOld -> (SomeException -> Bool)
-> (SomeException -> IO (Maybe (Ids v)))
-> IO (Maybe (Ids v))
-> IO (Maybe (Ids v))
forall e a.
Exception e =>
(e -> Bool) -> (e -> IO a) -> IO a -> IO a
handleBool (Bool -> Bool
not (Bool -> Bool) -> (SomeException -> Bool) -> SomeException -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Bool
isAsyncException) (\err :: SomeException
err -> do
[String] -> IO ()
outputErr ([String] -> IO ()) -> IO [String] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> SomeException -> IO [String]
messageCorrupt String
dbfile SomeException
err
IO ()
corrupt
Maybe (Ids v) -> IO (Maybe (Ids v))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Ids v)
forall a. Maybe a
Nothing) (IO (Maybe (Ids v)) -> IO (Maybe (Ids v)))
-> IO (Maybe (Ids v)) -> IO (Maybe (Ids v))
forall a b. (a -> b) -> a -> b
$ do
(![String]
missing, !ByteString -> (Id, Maybe (k, v))
load) <- ([String], ByteString -> (Id, Maybe (k, v)))
-> IO ([String], ByteString -> (Id, Maybe (k, v)))
forall a. a -> IO a
evaluate (([String], ByteString -> (Id, Maybe (k, v)))
-> IO ([String], ByteString -> (Id, Maybe (k, v))))
-> ([String], ByteString -> (Id, Maybe (k, v)))
-> IO ([String], ByteString -> (Id, Maybe (k, v)))
forall a b. (a -> b) -> a -> b
$ HashMap k (Ver, BinaryOp v)
-> ByteString -> ([String], ByteString -> (Id, Maybe (k, v)))
forall k v.
Show k =>
HashMap k (Ver, BinaryOp v)
-> ByteString -> ([String], ByteString -> (Id, Maybe (k, v)))
loadWitness HashMap k (Ver, BinaryOp v)
witness ByteString
witnessOld
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([String]
missing [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
/= []) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> IO ()
outputErr ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> [String]
messageMissingTypes String
dbfile [String]
missing
Ids (k, v)
ids <- IO (Ids (k, v))
forall a. IO (Ids a)
Ids.empty
let raw :: ByteString -> String
raw bs :: ByteString
bs = "[len " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (ByteString -> Int
BS.length ByteString
bs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "] " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[['0' | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c | Word8
x <- ByteString -> [Word8]
BS8.unpack ByteString
bs, let c :: String
c = Word8 -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showHex Word8
x ""]
let go :: a -> IO a
go !a
i = do
Either ByteString ByteString
v <- Chunks -> IO (Either ByteString ByteString)
readChunk Chunks
h
case Either ByteString ByteString
v of
Left e :: ByteString
e -> do
let slop :: Integer
slop = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
e
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
slop Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
unexpected (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Last " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
slop String -> String -> String
forall a. [a] -> [a] -> [a]
++ " bytes do not form a whole record\n"
IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ "Read " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ " chunks, plus " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
slop String -> String -> String
forall a. [a] -> [a] -> [a]
++ " slop"
a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
i
Right bs :: ByteString
bs | (id :: Id
id, Just (k :: k
k,v :: v
v)) <- ByteString -> (Id, Maybe (k, v))
load ByteString
bs -> do
() -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ k -> ()
forall a. NFData a => a -> ()
rnf k
k
() -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ v -> ()
forall a. NFData a => a -> ()
rnf v
v
Ids (k, v) -> Id -> (k, v) -> IO ()
forall a. Ids a -> Id -> a -> IO ()
Ids.insert Ids (k, v)
ids Id
id (k
k,v
v)
IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let pretty :: Either a String -> String
pretty (Left x :: a
x) = "FAILURE: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x
pretty (Right x :: String
x) = String
x
Either SomeException String
x2 <- IO String -> IO (Either SomeException String)
forall a. IO a -> IO (Either SomeException a)
try_ (IO String -> IO (Either SomeException String))
-> IO String -> IO (Either SomeException String)
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall a. a -> IO a
evaluate (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ let s :: String
s = v -> String
forall a. Show a => a -> String
show v
v in String -> ()
forall a. NFData a => a -> ()
rnf String
s () -> String -> String
forall a b. a -> b -> b
`seq` String
s
String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ "Chunk " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
raw ByteString
bs String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Id -> String
forall a. Show a => a -> String
show Id
id String -> String -> String
forall a. [a] -> [a] -> [a]
++ " = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Either SomeException String -> String
forall a. Show a => Either a String -> String
pretty Either SomeException String
x2
a -> IO a
go (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ a
ia -> a -> a
forall a. Num a => a -> a -> a
+1
Right bs :: ByteString
bs -> do
IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ "Chunk " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
raw ByteString
bs String -> String -> String
forall a. [a] -> [a] -> [a]
++ " UNKNOWN WITNESS"
a -> IO a
go a
i
Int
countItems <- Int -> IO Int
forall a. (Show a, Num a) => a -> IO a
go 0
Int
countDistinct <- Ids (k, v) -> IO Int
forall a. Ids a -> IO Int
Ids.sizeUpperBound Ids (k, v)
ids
IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ "Found at most " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
countDistinct String -> String -> String
forall a. [a] -> [a] -> [a]
++ " distinct entries out of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
countItems
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
countItems Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
countDistinctInt -> Int -> Int
forall a. Num a => a -> a -> a
*2 Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
verEq Bool -> Bool -> Bool
|| ByteString
witnessOld ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
witnessNew) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
addTiming "Database compression"
Chunks -> ((Builder -> IO ()) -> IO ()) -> IO ()
forall a. Chunks -> ((Builder -> IO ()) -> IO a) -> IO a
resetChunksCompact Chunks
h (((Builder -> IO ()) -> IO ()) -> IO ())
-> ((Builder -> IO ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \out :: Builder -> IO ()
out -> do
Builder -> IO ()
out (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
forall a. BinaryEx a => a -> Builder
putEx ByteString
ver
Builder -> IO ()
out (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
forall a. BinaryEx a => a -> Builder
putEx ByteString
witnessNew
Ids (k, v) -> (Id -> (k, v) -> IO ()) -> IO ()
forall a. Ids a -> (Id -> a -> IO ()) -> IO ()
Ids.forWithKeyM_ Ids (k, v)
ids ((Id -> (k, v) -> IO ()) -> IO ())
-> (Id -> (k, v) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \i :: Id
i (k :: k
k,v :: v
v) -> Builder -> IO ()
out (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ k -> Id -> v -> Builder
save k
k Id
i v
v
Ids v -> Maybe (Ids v)
forall a. a -> Maybe a
Just (Ids v -> Maybe (Ids v)) -> IO (Ids v) -> IO (Maybe (Ids v))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ids (k, v) -> ((k, v) -> v) -> IO (Ids v)
forall a b. Ids a -> (a -> b) -> IO (Ids b)
Ids.forCopy Ids (k, v)
ids (k, v) -> v
forall a b. (a, b) -> b
snd
Ids v
ids <- case Maybe (Ids v)
ids of
Just ids :: Ids v
ids -> Ids v -> IO (Ids v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ids v
ids
Nothing -> do
Chunks -> Builder -> IO ()
writeChunk Chunks
h (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
forall a. BinaryEx a => a -> Builder
putEx ByteString
ver
Chunks -> Builder -> IO ()
writeChunk Chunks
h (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
forall a. BinaryEx a => a -> Builder
putEx ByteString
witnessNew
IO (Ids v)
forall a. IO (Ids a)
Ids.empty
String -> IO ()
addTiming "With database"
Builder -> IO ()
out <- Cleanup -> Chunks -> IO (Builder -> IO ())
usingWriteChunks Cleanup
cleanup Chunks
h
(Ids v, k -> Id -> v -> IO ()) -> IO (Ids v, k -> Id -> v -> IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ids v
ids, \k :: k
k i :: Id
i v :: v
v -> Builder -> IO ()
out (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ k -> Id -> v -> Builder
save k
k Id
i v
v)
where
unexpected :: String -> IO ()
unexpected x :: String
x = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shakeStorageLog (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
UTCTime
t <- IO UTCTime
getCurrentTime
String -> String -> IO ()
appendFile (String
shakeFiles String -> String -> String
</> ".shake.storage.log") (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "\n[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UTCTime -> String
forall a. Show a => a -> String
show UTCTime
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ "]: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
trimEnd String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n"
outputErr :: [String] -> IO ()
outputErr x :: [String]
x = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
shakeVerbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Warn) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
shakeOutput Verbosity
Warn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
x
String -> IO ()
unexpected (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
x
type Witnesses = BS.ByteString
newtype Witness = Witness BS.ByteString
deriving (Witness -> Witness -> Bool
(Witness -> Witness -> Bool)
-> (Witness -> Witness -> Bool) -> Eq Witness
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Witness -> Witness -> Bool
$c/= :: Witness -> Witness -> Bool
== :: Witness -> Witness -> Bool
$c== :: Witness -> Witness -> Bool
Eq, Int -> Witness -> Int
Witness -> Int
(Int -> Witness -> Int) -> (Witness -> Int) -> Hashable Witness
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Witness -> Int
$chash :: Witness -> Int
hashWithSalt :: Int -> Witness -> Int
$chashWithSalt :: Int -> Witness -> Int
Hashable, Eq Witness
Eq Witness =>
(Witness -> Witness -> Ordering)
-> (Witness -> Witness -> Bool)
-> (Witness -> Witness -> Bool)
-> (Witness -> Witness -> Bool)
-> (Witness -> Witness -> Bool)
-> (Witness -> Witness -> Witness)
-> (Witness -> Witness -> Witness)
-> Ord Witness
Witness -> Witness -> Bool
Witness -> Witness -> Ordering
Witness -> Witness -> Witness
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Witness -> Witness -> Witness
$cmin :: Witness -> Witness -> Witness
max :: Witness -> Witness -> Witness
$cmax :: Witness -> Witness -> Witness
>= :: Witness -> Witness -> Bool
$c>= :: Witness -> Witness -> Bool
> :: Witness -> Witness -> Bool
$c> :: Witness -> Witness -> Bool
<= :: Witness -> Witness -> Bool
$c<= :: Witness -> Witness -> Bool
< :: Witness -> Witness -> Bool
$c< :: Witness -> Witness -> Bool
compare :: Witness -> Witness -> Ordering
$ccompare :: Witness -> Witness -> Ordering
$cp1Ord :: Eq Witness
Ord)
toWitness :: Show k => Ver -> k -> Witness
toWitness :: Ver -> k -> Witness
toWitness (Ver v :: Int
v) k :: k
k = ByteString -> Witness
Witness (ByteString -> Witness) -> ByteString -> Witness
forall a b. (a -> b) -> a -> b
$ String -> ByteString
UTF8.fromString (k -> String
forall a. Show a => a -> String
show k
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Int
v Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then "" else ", v" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
v))
instance BinaryEx [Witness] where
putEx :: [Witness] -> Builder
putEx xs :: [Witness]
xs = [ByteString] -> Builder
forall a. BinaryEx a => a -> Builder
putEx [ByteString
x | Witness x :: ByteString
x <- [Witness]
xs]
getEx :: ByteString -> [Witness]
getEx = (ByteString -> Witness) -> [ByteString] -> [Witness]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Witness
Witness ([ByteString] -> [Witness])
-> (ByteString -> [ByteString]) -> ByteString -> [Witness]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
forall a. BinaryEx a => ByteString -> a
getEx
loadWitness :: forall k v . Show k => Map.HashMap k (Ver, BinaryOp v) -> Witnesses -> ([String], BS.ByteString -> (Id, Maybe (k, v)))
loadWitness :: HashMap k (Ver, BinaryOp v)
-> ByteString -> ([String], ByteString -> (Id, Maybe (k, v)))
loadWitness mp :: HashMap k (Ver, BinaryOp v)
mp bs :: ByteString
bs = (,) [String]
missing ((ByteString -> (Id, Maybe (k, v)))
-> ([String], ByteString -> (Id, Maybe (k, v))))
-> (ByteString -> (Id, Maybe (k, v)))
-> ([String], ByteString -> (Id, Maybe (k, v)))
forall a b. (a -> b) -> a -> b
$ (Int -> Maybe (ByteString -> Maybe (k, v)))
-> (ByteString -> (Id, Maybe (k, v)))
-> ByteString
-> (Id, Maybe (k, v))
forall a b. a -> b -> b
seq Int -> Maybe (ByteString -> Maybe (k, v))
ind ((ByteString -> (Id, Maybe (k, v)))
-> ByteString -> (Id, Maybe (k, v)))
-> (ByteString -> (Id, Maybe (k, v)))
-> ByteString
-> (Id, Maybe (k, v))
forall a b. (a -> b) -> a -> b
$ \bs :: ByteString
bs ->
let (Word16
wInd :: Word16, Id
i :: Id, bs2 :: ByteString
bs2) = ByteString -> (Word16, Id, ByteString)
forall a b.
(Storable a, Storable b) =>
ByteString -> (a, b, ByteString)
binarySplit2 ByteString
bs
in case Int -> Maybe (ByteString -> Maybe (k, v))
ind (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
wInd) of
Nothing -> SomeException -> (Id, Maybe (k, v))
forall a. SomeException -> a
throwImpure (SomeException -> (Id, Maybe (k, v)))
-> SomeException -> (Id, Maybe (k, v))
forall a b. (a -> b) -> a -> b
$ Partial => String -> SomeException
String -> SomeException
errorInternal (String -> SomeException) -> String -> SomeException
forall a b. (a -> b) -> a -> b
$ "Witness index out of bounds, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word16 -> String
forall a. Show a => a -> String
show Word16
wInd
Just f :: ByteString -> Maybe (k, v)
f -> (Id
i, ByteString -> Maybe (k, v)
f ByteString
bs2)
where
[Witness]
ws :: [Witness] = ByteString -> [Witness]
forall a. BinaryEx a => ByteString -> a
getEx ByteString
bs
missing :: [String]
missing = [ByteString -> String
UTF8.toString ByteString
w | (i :: Int
i, Witness w :: ByteString
w) <- Int -> [Witness] -> [(Int, Witness)]
forall a b. Enum a => a -> [b] -> [(a, b)]
zipFrom 0 [Witness]
ws, Maybe (k, v) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (k, v) -> Bool) -> Maybe (k, v) -> Bool
forall a b. (a -> b) -> a -> b
$ Maybe (ByteString -> Maybe (k, v)) -> ByteString -> Maybe (k, v)
forall a. Partial => Maybe a -> a
fromJust (Int -> Maybe (ByteString -> Maybe (k, v))
ind Int
i) ByteString
BS.empty]
HashMap Witness (k, BinaryOp v)
mp2 :: Map.HashMap Witness (k, BinaryOp v) = [(Witness, (k, BinaryOp v))] -> HashMap Witness (k, BinaryOp v)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList [(Ver -> k -> Witness
forall k. Show k => Ver -> k -> Witness
toWitness Ver
ver k
k, (k
k, BinaryOp v
bin)) | (k :: k
k,(ver :: Ver
ver,bin :: BinaryOp v
bin)) <- HashMap k (Ver, BinaryOp v) -> [(k, (Ver, BinaryOp v))]
forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap k (Ver, BinaryOp v)
mp]
Int -> Maybe (ByteString -> Maybe (k, v))
ind :: (Int -> Maybe (BS.ByteString -> Maybe (k, v))) = HashMap Witness (k, BinaryOp v)
-> (Int -> Maybe (ByteString -> Maybe (k, v)))
-> Int
-> Maybe (ByteString -> Maybe (k, v))
forall a b. a -> b -> b
seq HashMap Witness (k, BinaryOp v)
mp2 ((Int -> Maybe (ByteString -> Maybe (k, v)))
-> Int -> Maybe (ByteString -> Maybe (k, v)))
-> (Int -> Maybe (ByteString -> Maybe (k, v)))
-> Int
-> Maybe (ByteString -> Maybe (k, v))
forall a b. (a -> b) -> a -> b
$ [ByteString -> Maybe (k, v)]
-> Int -> Maybe (ByteString -> Maybe (k, v))
forall a. [a] -> Int -> Maybe a
fastAt ([ByteString -> Maybe (k, v)]
-> Int -> Maybe (ByteString -> Maybe (k, v)))
-> [ByteString -> Maybe (k, v)]
-> Int
-> Maybe (ByteString -> Maybe (k, v))
forall a b. (a -> b) -> a -> b
$ ((Witness -> ByteString -> Maybe (k, v))
-> [Witness] -> [ByteString -> Maybe (k, v)])
-> [Witness]
-> (Witness -> ByteString -> Maybe (k, v))
-> [ByteString -> Maybe (k, v)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Witness -> ByteString -> Maybe (k, v))
-> [Witness] -> [ByteString -> Maybe (k, v)]
forall a b. (a -> b) -> [a] -> [b]
map [Witness]
ws ((Witness -> ByteString -> Maybe (k, v))
-> [ByteString -> Maybe (k, v)])
-> (Witness -> ByteString -> Maybe (k, v))
-> [ByteString -> Maybe (k, v)]
forall a b. (a -> b) -> a -> b
$ \w :: Witness
w ->
case Witness -> HashMap Witness (k, BinaryOp v) -> Maybe (k, BinaryOp v)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Witness
w HashMap Witness (k, BinaryOp v)
mp2 of
Nothing -> Maybe (k, v) -> ByteString -> Maybe (k, v)
forall a b. a -> b -> a
const Maybe (k, v)
forall a. Maybe a
Nothing
Just (k :: k
k, BinaryOp{..}) -> \bs :: ByteString
bs -> (k, v) -> Maybe (k, v)
forall a. a -> Maybe a
Just (k
k, ByteString -> v
getOp ByteString
bs)
saveWitness :: forall k v . (Eq k, Hashable k, Show k) => Map.HashMap k (Ver, BinaryOp v) -> (Witnesses, k -> Id -> v -> Builder)
saveWitness :: HashMap k (Ver, BinaryOp v)
-> (ByteString, k -> Id -> v -> Builder)
saveWitness mp :: HashMap k (Ver, BinaryOp v)
mp
| HashMap k (Ver, BinaryOp v) -> Int
forall k v. HashMap k v -> Int
Map.size HashMap k (Ver, BinaryOp v)
mp Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
forall a. Bounded a => a
maxBound :: Word16) = SomeException -> (ByteString, k -> Id -> v -> Builder)
forall a. SomeException -> a
throwImpure (SomeException -> (ByteString, k -> Id -> v -> Builder))
-> SomeException -> (ByteString, k -> Id -> v -> Builder)
forall a b. (a -> b) -> a -> b
$ Partial => String -> SomeException
String -> SomeException
errorInternal (String -> SomeException) -> String -> SomeException
forall a b. (a -> b) -> a -> b
$ "Number of distinct witness types exceeds limit, got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (HashMap k (Ver, BinaryOp v) -> Int
forall k v. HashMap k v -> Int
Map.size HashMap k (Ver, BinaryOp v)
mp)
| Bool
otherwise = (Builder -> ByteString
runBuilder (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ [Witness] -> Builder
forall a. BinaryEx a => a -> Builder
putEx [Witness]
ws
,HashMap k (Id -> v -> Builder)
mpSave HashMap k (Id -> v -> Builder)
-> (k -> Id -> v -> Builder) -> k -> Id -> v -> Builder
forall a b. a -> b -> b
`seq` \k :: k
k -> (Id -> v -> Builder)
-> Maybe (Id -> v -> Builder) -> Id -> v -> Builder
forall a. a -> Maybe a -> a
fromMaybe (SomeException -> Id -> v -> Builder
forall a. SomeException -> a
throwImpure (SomeException -> Id -> v -> Builder)
-> SomeException -> Id -> v -> Builder
forall a b. (a -> b) -> a -> b
$ Partial => String -> SomeException
String -> SomeException
errorInternal (String -> SomeException) -> String -> SomeException
forall a b. (a -> b) -> a -> b
$ "Don't know how to save, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ k -> String
forall a. Show a => a -> String
show k
k) (Maybe (Id -> v -> Builder) -> Id -> v -> Builder)
-> Maybe (Id -> v -> Builder) -> Id -> v -> Builder
forall a b. (a -> b) -> a -> b
$ k -> HashMap k (Id -> v -> Builder) -> Maybe (Id -> v -> Builder)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup k
k HashMap k (Id -> v -> Builder)
mpSave)
where
[Witness]
ws :: [Witness] = [Witness] -> [Witness]
forall a. Ord a => [a] -> [a]
sort ([Witness] -> [Witness]) -> [Witness] -> [Witness]
forall a b. (a -> b) -> a -> b
$ ((k, (Ver, BinaryOp v)) -> Witness)
-> [(k, (Ver, BinaryOp v))] -> [Witness]
forall a b. (a -> b) -> [a] -> [b]
map (\(k :: k
k,(ver :: Ver
ver,_)) -> Ver -> k -> Witness
forall k. Show k => Ver -> k -> Witness
toWitness Ver
ver k
k) ([(k, (Ver, BinaryOp v))] -> [Witness])
-> [(k, (Ver, BinaryOp v))] -> [Witness]
forall a b. (a -> b) -> a -> b
$ HashMap k (Ver, BinaryOp v) -> [(k, (Ver, BinaryOp v))]
forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap k (Ver, BinaryOp v)
mp
HashMap Witness Word16
wsIndex :: Map.HashMap Witness Word16 = [(Witness, Word16)] -> HashMap Witness Word16
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(Witness, Word16)] -> HashMap Witness Word16)
-> [(Witness, Word16)] -> HashMap Witness Word16
forall a b. (a -> b) -> a -> b
$ [Witness] -> [Word16] -> [(Witness, Word16)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Witness]
ws [0 :: Word16 ..]
HashMap k (Id -> v -> Builder)
mpSave :: Map.HashMap k (Id -> v -> Builder) = ((k -> (Ver, BinaryOp v) -> Id -> v -> Builder)
-> HashMap k (Ver, BinaryOp v) -> HashMap k (Id -> v -> Builder))
-> HashMap k (Ver, BinaryOp v)
-> (k -> (Ver, BinaryOp v) -> Id -> v -> Builder)
-> HashMap k (Id -> v -> Builder)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (k -> (Ver, BinaryOp v) -> Id -> v -> Builder)
-> HashMap k (Ver, BinaryOp v) -> HashMap k (Id -> v -> Builder)
forall k v1 v2. (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.mapWithKey HashMap k (Ver, BinaryOp v)
mp ((k -> (Ver, BinaryOp v) -> Id -> v -> Builder)
-> HashMap k (Id -> v -> Builder))
-> (k -> (Ver, BinaryOp v) -> Id -> v -> Builder)
-> HashMap k (Id -> v -> Builder)
forall a b. (a -> b) -> a -> b
$
\k :: k
k (ver :: Ver
ver,BinaryOp{..}) ->
let tag :: Builder
tag = Word16 -> Builder
forall a. BinaryEx a => a -> Builder
putEx (Word16 -> Builder) -> Word16 -> Builder
forall a b. (a -> b) -> a -> b
$ HashMap Witness Word16
wsIndex HashMap Witness Word16 -> Witness -> Word16
forall k v. (Eq k, Hashable k) => HashMap k v -> k -> v
Map.! Ver -> k -> Witness
forall k. Show k => Ver -> k -> Witness
toWitness Ver
ver k
k
in \(Id w :: Word32
w) v :: v
v -> Builder
tag Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
forall a. BinaryEx a => a -> Builder
putEx Word32
w Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> v -> Builder
putOp v
v