{-# LANGUAGE ScopedTypeVariables, RecordWildCards, FlexibleInstances #-}
{-# LANGUAGE BangPatterns #-}
module Development.Shake.Internal.Core.Storage(
withStorage
) where
import General.Chunks
import General.Binary
import General.Intern
import Development.Shake.Internal.Options
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 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 Data.Functor
import Prelude
databaseVersion :: String -> String
databaseVersion :: String -> String
databaseVersion x :: String
x = "SHAKE-DATABASE-13-" 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
withStorage
:: (Show k, Eq k, Hashable k, NFData k, Show v, NFData v)
=> ShakeOptions
-> (IO String -> IO ())
-> Map.HashMap k (BinaryOp v)
-> (Ids.Ids v -> (k -> Id -> v -> IO ()) -> IO a)
-> IO a
withStorage :: ShakeOptions
-> (IO String -> IO ())
-> HashMap k (BinaryOp v)
-> (Ids v -> (k -> Id -> v -> IO ()) -> IO a)
-> IO a
withStorage ShakeOptions{..} diagnostic :: IO String -> IO ()
diagnostic witness :: HashMap k (BinaryOp v)
witness act :: Ids v -> (k -> Id -> v -> IO ()) -> IO a
act = (IO String -> IO ()) -> String -> IO a -> IO a
forall a. (IO String -> IO ()) -> String -> IO a -> IO a
withLockFileDiagnostic IO String -> IO ()
diagnostic (String
shakeFiles String -> String -> String
</> ".shake.lock") (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
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 (m :: * -> *) a. Monad m => a -> m a
return "Backup file move to original"
String -> IO ()
addTiming "Database read"
String -> Maybe Double -> (Chunks -> IO a) -> IO a
forall a. String -> Maybe Double -> (Chunks -> IO a) -> IO a
withChunks String
dbfile Maybe Double
shakeFlush ((Chunks -> IO a) -> IO a) -> (Chunks -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \h :: Chunks
h -> do
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
let 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 "...")
let 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 -> IO ()
outputErr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
["Error when reading Shake database - invalid version stamp detected:"
," File: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dbfile
," Expected: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
disp (ByteString -> String
BS.unpack ByteString
ver)
," Found: " 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 -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Either ByteString ByteString -> ByteString
forall a. Either a a -> a
fromEither Either ByteString ByteString
oldVer)
,"All rules will be rebuilt"]
IO ()
corrupt
let (witnessNew :: ByteString
witnessNew, save :: k -> Id -> v -> Builder
save) = HashMap k (BinaryOp v) -> (ByteString, k -> Id -> v -> Builder)
forall k v.
(Eq k, Hashable k, Show k) =>
HashMap k (BinaryOp v) -> (ByteString, k -> Id -> v -> Builder)
putWitness HashMap k (BinaryOp v)
witness
(k -> Id -> v -> Builder) -> IO (k -> Id -> v -> Builder)
forall a. a -> IO a
evaluate k -> Id -> v -> Builder
save
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 (m :: * -> *) a. Monad m => a -> m a
return 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
msg <- SomeException -> IO String
forall e. Show e => e -> IO String
showException SomeException
err
String -> IO ()
outputErr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> 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"]
IO ()
corrupt
Maybe (Ids v) -> IO (Maybe (Ids v))
forall (m :: * -> *) a. Monad m => a -> m a
return 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
let load :: ByteString -> (k, Id, v)
load = ByteString -> HashMap k (BinaryOp v) -> ByteString -> (k, Id, v)
forall k v.
Show k =>
ByteString -> HashMap k (BinaryOp v) -> ByteString -> (k, Id, v)
getWitness ByteString
witnessOld HashMap k (BinaryOp v)
witness
(ByteString -> (k, Id, v)) -> IO (ByteString -> (k, Id, v))
forall a. a -> IO a
evaluate ByteString -> (k, Id, v)
load
Ids (k, v)
ids <- IO (Ids (k, v))
forall a. IO (Ids a)
Ids.empty
let go :: t -> IO t
go !t
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 (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ "Read " String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
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"
t -> IO t
forall (m :: * -> *) a. Monad m => a -> m a
return t
i
Right bs :: ByteString
bs -> do
let (k :: k
k,id :: Id
id,v :: v
v) = ByteString -> (k, Id, v)
load ByteString
bs
() -> 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 raw :: p -> String
raw x :: p
x = "[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 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 (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ "Chunk " String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall p. p -> 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
t -> IO t
go (t -> IO t) -> t -> IO t
forall a b. (a -> b) -> a -> b
$ t
it -> t -> t
forall a. Num a => a -> a -> a
+1
Int
countItems <- Int -> IO Int
forall t. (Show t, Num t) => t -> IO t
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 (m :: * -> *) a. Monad m => a -> m a
return (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.for 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 (m :: * -> *) a. Monad m => a -> m a
return 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"
Chunks -> ((Builder -> IO ()) -> IO a) -> IO a
forall a. Chunks -> ((Builder -> IO ()) -> IO a) -> IO a
writeChunks Chunks
h (((Builder -> IO ()) -> IO a) -> IO a)
-> ((Builder -> IO ()) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \out :: Builder -> IO ()
out ->
Ids v -> (k -> Id -> v -> IO ()) -> IO a
act Ids v
ids ((k -> Id -> v -> IO ()) -> IO a)
-> (k -> Id -> v -> IO ()) -> IO a
forall a b. (a -> b) -> a -> b
$ \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
Quiet) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
shakeOutput Verbosity
Quiet String
x
String -> IO ()
unexpected String
x
keyName :: Show k => k -> BS.ByteString
keyName :: k -> ByteString
keyName = String -> ByteString
UTF8.fromString (String -> ByteString) -> (k -> String) -> k -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> String
forall a. Show a => a -> String
show
getWitness :: Show k => BS.ByteString -> Map.HashMap k (BinaryOp v) -> (BS.ByteString -> (k, Id, v))
getWitness :: ByteString -> HashMap k (BinaryOp v) -> ByteString -> (k, Id, v)
getWitness bs :: ByteString
bs mp :: HashMap k (BinaryOp v)
mp
| [ByteString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
ws Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
limit Bool -> Bool -> Bool
|| HashMap k (BinaryOp v) -> Int
forall k v. HashMap k v -> Int
Map.size HashMap k (BinaryOp v)
mp Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
limit = String -> ByteString -> (k, Id, v)
forall a. HasCallStack => String -> a
error "Number of distinct witness types exceeds limit"
| Bool
otherwise = Int -> Maybe (ByteString -> (k, Id, v))
ind (Int -> Maybe (ByteString -> (k, Id, v)))
-> (ByteString -> (k, Id, v)) -> ByteString -> (k, Id, v)
forall a b. a -> b -> b
`seq` HashMap ByteString (k, BinaryOp v)
mp2 HashMap ByteString (k, BinaryOp v)
-> (ByteString -> (k, Id, v)) -> ByteString -> (k, Id, v)
forall a b. a -> b -> b
`seq` \bs :: ByteString
bs ->
let (Word16
k :: Word16,bs2 :: ByteString
bs2) = ByteString -> (Word16, ByteString)
forall a. Storable a => ByteString -> (a, ByteString)
binarySplit ByteString
bs
in case Int -> Maybe (ByteString -> (k, Id, v))
ind (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
k) of
Nothing -> String -> (k, Id, v)
forall a. HasCallStack => String -> a
error (String -> (k, Id, v)) -> String -> (k, Id, v)
forall a b. (a -> b) -> a -> b
$ "Witness type out of bounds, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word16 -> String
forall a. Show a => a -> String
show Word16
k
Just f :: ByteString -> (k, Id, v)
f -> ByteString -> (k, Id, v)
f ByteString
bs2
where
limit :: Int
limit = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
forall a. Bounded a => a
maxBound :: Word16)
[ByteString]
ws :: [BS.ByteString] = ByteString -> [ByteString]
forall a. BinaryEx a => ByteString -> a
getEx ByteString
bs
mp2 :: HashMap ByteString (k, BinaryOp v)
mp2 = [(ByteString, (k, BinaryOp v))]
-> HashMap ByteString (k, BinaryOp v)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList [(k -> ByteString
forall k. Show k => k -> ByteString
keyName k
k, (k
k, BinaryOp v
v)) | (k :: k
k,v :: BinaryOp v
v) <- HashMap k (BinaryOp v) -> [(k, BinaryOp v)]
forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap k (BinaryOp v)
mp]
ind :: Int -> Maybe (ByteString -> (k, Id, v))
ind = [ByteString -> (k, Id, v)]
-> Int -> Maybe (ByteString -> (k, Id, v))
forall a. [a] -> Int -> Maybe a
fastAt [ case ByteString
-> HashMap ByteString (k, BinaryOp v) -> Maybe (k, BinaryOp v)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup ByteString
w HashMap ByteString (k, BinaryOp v)
mp2 of
Nothing -> String -> ByteString -> (k, Id, v)
forall a. HasCallStack => String -> a
error (String -> ByteString -> (k, Id, v))
-> String -> ByteString -> (k, Id, v)
forall a b. (a -> b) -> a -> b
$ "Witness type has disappeared, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
UTF8.toString ByteString
w
Just (k :: k
k, BinaryOp{..}) -> \bs :: ByteString
bs ->
let (i :: Id
i, bs2 :: ByteString
bs2) = ByteString -> (Id, ByteString)
forall a. Storable a => ByteString -> (a, ByteString)
binarySplit ByteString
bs
v :: v
v = ByteString -> v
getOp ByteString
bs2
in (k
k, Id
i, v
v)
| ByteString
w <- [ByteString]
ws]
putWitness :: (Eq k, Hashable k, Show k) => Map.HashMap k (BinaryOp v) -> (BS.ByteString, k -> Id -> v -> Builder)
putWitness :: HashMap k (BinaryOp v) -> (ByteString, k -> Id -> v -> Builder)
putWitness mp :: HashMap k (BinaryOp v)
mp = (Builder -> ByteString
runBuilder (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> Builder
forall a. BinaryEx a => a -> Builder
putEx ([ByteString]
ws :: [BS.ByteString]), HashMap k (Id -> v -> Builder)
mp2 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 (String -> Id -> v -> Builder
forall a. HasCallStack => String -> a
error (String -> Id -> v -> Builder) -> String -> Id -> v -> Builder
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)
mp2)
where
ws :: [ByteString]
ws = [ByteString] -> [ByteString]
forall a. Ord a => [a] -> [a]
sort ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ (k -> ByteString) -> [k] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map k -> ByteString
forall k. Show k => k -> ByteString
keyName ([k] -> [ByteString]) -> [k] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ HashMap k (BinaryOp v) -> [k]
forall k v. HashMap k v -> [k]
Map.keys HashMap k (BinaryOp v)
mp
wsMp :: HashMap ByteString Word16
wsMp = [(ByteString, Word16)] -> HashMap ByteString Word16
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(ByteString, Word16)] -> HashMap ByteString Word16)
-> [(ByteString, Word16)] -> HashMap ByteString Word16
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [Word16] -> [(ByteString, Word16)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ByteString]
ws [0 :: Word16 ..]
mp2 :: HashMap k (Id -> v -> Builder)
mp2 = (k -> BinaryOp v -> Id -> v -> Builder)
-> HashMap k (BinaryOp v) -> HashMap k (Id -> v -> Builder)
forall k v1 v2. (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.mapWithKey (\k :: k
k 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 ByteString Word16
wsMp HashMap ByteString Word16 -> ByteString -> Word16
forall k v. (Eq k, Hashable k) => HashMap k v -> k -> v
Map.! k -> ByteString
forall k. Show k => k -> ByteString
keyName 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) HashMap k (BinaryOp v)
mp
withLockFileDiagnostic :: (IO String -> IO ()) -> FilePath -> IO a -> IO a
withLockFileDiagnostic :: (IO String -> IO ()) -> String -> IO a -> IO a
withLockFileDiagnostic diagnostic :: IO String -> IO ()
diagnostic file :: String
file act :: IO a
act = do
IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ "Before withLockFile on " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file
a
res <- String -> IO a -> IO a
forall a. String -> IO a -> IO a
withLockFile String
file (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return "Inside withLockFile"
IO a
act
IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return "After withLockFile"
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res