{-# LANGUAGE ScopedTypeVariables, RecordWildCards, FlexibleInstances #-}
{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-}
{-
This module stores the meta-data so its very important its always accurate
We can't rely on getting any exceptions or termination at the end, so we'd better write out a journal
We store a series of records, and if they contain twice as many records as needed, we compact
-}

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


-- Increment every time the on-disk format/semantics change,
-- @x@ is for the users version number
databaseVersion :: String -> String
-- THINGS I WANT TO DO ON THE NEXT CHANGE
-- * Change filepaths to store a 1 byte prefix saying 8bit ASCII or UTF8
-- * Duration and Time should be stored as number of 1/10000th seconds Int32
databaseVersion :: String -> String
databaseVersion String
x = String
"SHAKE-DATABASE-14-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
os String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
arch String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++  String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\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 -- call show, then take off the leading/trailing quotes
                                   -- ensures we do not get \r or \n in the user portion


messageCorrupt :: FilePath -> SomeException -> IO [String]
messageCorrupt :: String -> SomeException -> IO [String]
messageCorrupt String
dbfile 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
$
        (String
"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 -> String
forall a. [a] -> [a] -> [a]
++) (String -> [String]
lines String
msg) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
        [String
"All files will be rebuilt"]


messageDatabaseVersionChange :: FilePath -> BS.ByteString -> BS.ByteString -> [String]
messageDatabaseVersionChange :: String -> ByteString -> ByteString -> [String]
messageDatabaseVersionChange String
dbfile ByteString
old ByteString
new =
    [String
"Shake database version changed (either shake library version, or shakeVersion):"
    ,String
"  File:         " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dbfile
    ,String
"  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)
    ,String
"  New version:  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
disp (ByteString -> String
BS.unpack ByteString
new)
    ,String
"All rules will be rebuilt"]
    where
        limit :: String -> String
limit String
x = let (String
a,String
b) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
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 String
"" else String
"...")
        disp :: String -> String
disp = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (\Char
x -> if Char -> Bool
isPrint Char
x Bool -> Bool -> Bool
&& Char -> Bool
isAscii Char
x then Char
x else Char
'?') (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` (String
"\r\n" :: String))


messageMissingTypes :: FilePath -> [String] -> [String]
messageMissingTypes :: String -> [String] -> [String]
messageMissingTypes String
dbfile [String]
types =
    [String
"Shake database rules have changed for the following types:"
    ,String
"  File:  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dbfile] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
    [String
"  Type:  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x | String
x <- [String]
types] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
    [String
"All rules using these types will be rebuilt"]


-- | Storage of heterogeneous things. In the particular case of Shake,
--   k ~ QTypeRep, v ~ (Key, Status{Value}).
--
--   The storage starts with a witness table saying what can be contained.
--   If any entries in the witness table don't have a current Witness then a fake
--   error witness is manufactured. If the witness ever changes the entire DB is
--   rewritten.
usingStorage
    :: (Show k, Eq k, Hashable k, NFData k, Show v, NFData v)
    => Cleanup
    -> ShakeOptions                                    -- ^ Storage options
    -> (IO String -> IO ())                            -- ^ Logging function
    -> Map.HashMap k (Ver, BinaryOp v)                 -- ^ Witnesses
    -> 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 Cleanup
_ ShakeOptions{Bool
Int
String
[String]
[(String, String)]
[(Rebuild, String)]
[CmdOption]
Maybe Seconds
Maybe String
Maybe Lint
HashMap TypeRep Dynamic
Verbosity
Change
String -> String -> Bool -> IO ()
IO Progress -> IO ()
Verbosity -> String -> IO ()
shakeExtra :: ShakeOptions -> HashMap TypeRep Dynamic
shakeTrace :: ShakeOptions -> String -> String -> Bool -> IO ()
shakeOutput :: ShakeOptions -> Verbosity -> String -> IO ()
shakeProgress :: ShakeOptions -> IO Progress -> IO ()
shakeNeedDirectory :: ShakeOptions -> Bool
shakeSymlink :: ShakeOptions -> Bool
shakeCloud :: ShakeOptions -> [String]
shakeShare :: ShakeOptions -> Maybe String
shakeColor :: ShakeOptions -> Bool
shakeVersionIgnore :: ShakeOptions -> Bool
shakeLiveFiles :: ShakeOptions -> [String]
shakeCreationCheck :: ShakeOptions -> Bool
shakeChange :: ShakeOptions -> Change
shakeRunCommands :: ShakeOptions -> Bool
shakeTimings :: ShakeOptions -> Bool
shakeLineBuffering :: ShakeOptions -> Bool
shakeStorageLog :: ShakeOptions -> Bool
shakeAbbreviations :: ShakeOptions -> [(String, String)]
shakeRebuild :: ShakeOptions -> [(Rebuild, String)]
shakeFlush :: ShakeOptions -> Maybe Seconds
shakeCommandOptions :: ShakeOptions -> [CmdOption]
shakeLintWatch :: ShakeOptions -> [String]
shakeLintIgnore :: ShakeOptions -> [String]
shakeLintInside :: ShakeOptions -> [String]
shakeLint :: ShakeOptions -> Maybe Lint
shakeReport :: ShakeOptions -> [String]
shakeStaunch :: ShakeOptions -> Bool
shakeVerbosity :: ShakeOptions -> Verbosity
shakeVersion :: ShakeOptions -> String
shakeThreads :: ShakeOptions -> Int
shakeFiles :: ShakeOptions -> String
shakeExtra :: HashMap TypeRep Dynamic
shakeTrace :: String -> String -> Bool -> IO ()
shakeOutput :: Verbosity -> String -> IO ()
shakeProgress :: IO Progress -> IO ()
shakeNeedDirectory :: Bool
shakeSymlink :: Bool
shakeCloud :: [String]
shakeShare :: Maybe String
shakeColor :: Bool
shakeVersionIgnore :: Bool
shakeLiveFiles :: [String]
shakeCreationCheck :: Bool
shakeChange :: Change
shakeRunCommands :: Bool
shakeTimings :: Bool
shakeLineBuffering :: Bool
shakeStorageLog :: Bool
shakeAbbreviations :: [(String, String)]
shakeRebuild :: [(Rebuild, String)]
shakeFlush :: Maybe Seconds
shakeCommandOptions :: [CmdOption]
shakeLintWatch :: [String]
shakeLintIgnore :: [String]
shakeLintInside :: [String]
shakeLint :: Maybe Lint
shakeReport :: [String]
shakeStaunch :: Bool
shakeVerbosity :: Verbosity
shakeVersion :: String
shakeThreads :: Int
shakeFiles :: String
..} IO String -> IO ()
diagnostic HashMap k (Ver, BinaryOp v)
_ | String
shakeFiles String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"/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 String
"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, \k
_ Id
_ v
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

usingStorage Cleanup
cleanup ShakeOptions{Bool
Int
String
[String]
[(String, String)]
[(Rebuild, String)]
[CmdOption]
Maybe Seconds
Maybe String
Maybe Lint
HashMap TypeRep Dynamic
Verbosity
Change
String -> String -> Bool -> IO ()
IO Progress -> IO ()
Verbosity -> String -> IO ()
shakeExtra :: HashMap TypeRep Dynamic
shakeTrace :: String -> String -> Bool -> IO ()
shakeOutput :: Verbosity -> String -> IO ()
shakeProgress :: IO Progress -> IO ()
shakeNeedDirectory :: Bool
shakeSymlink :: Bool
shakeCloud :: [String]
shakeShare :: Maybe String
shakeColor :: Bool
shakeVersionIgnore :: Bool
shakeLiveFiles :: [String]
shakeCreationCheck :: Bool
shakeChange :: Change
shakeRunCommands :: Bool
shakeTimings :: Bool
shakeLineBuffering :: Bool
shakeStorageLog :: Bool
shakeAbbreviations :: [(String, String)]
shakeRebuild :: [(Rebuild, String)]
shakeFlush :: Maybe Seconds
shakeCommandOptions :: [CmdOption]
shakeLintWatch :: [String]
shakeLintIgnore :: [String]
shakeLintInside :: [String]
shakeLint :: Maybe Lint
shakeReport :: [String]
shakeStaunch :: Bool
shakeVerbosity :: Verbosity
shakeVersion :: String
shakeThreads :: Int
shakeFiles :: String
shakeExtra :: ShakeOptions -> HashMap TypeRep Dynamic
shakeTrace :: ShakeOptions -> String -> String -> Bool -> IO ()
shakeOutput :: ShakeOptions -> Verbosity -> String -> IO ()
shakeProgress :: ShakeOptions -> IO Progress -> IO ()
shakeNeedDirectory :: ShakeOptions -> Bool
shakeSymlink :: ShakeOptions -> Bool
shakeCloud :: ShakeOptions -> [String]
shakeShare :: ShakeOptions -> Maybe String
shakeColor :: ShakeOptions -> Bool
shakeVersionIgnore :: ShakeOptions -> Bool
shakeLiveFiles :: ShakeOptions -> [String]
shakeCreationCheck :: ShakeOptions -> Bool
shakeChange :: ShakeOptions -> Change
shakeRunCommands :: ShakeOptions -> Bool
shakeTimings :: ShakeOptions -> Bool
shakeLineBuffering :: ShakeOptions -> Bool
shakeStorageLog :: ShakeOptions -> Bool
shakeAbbreviations :: ShakeOptions -> [(String, String)]
shakeRebuild :: ShakeOptions -> [(Rebuild, String)]
shakeFlush :: ShakeOptions -> Maybe Seconds
shakeCommandOptions :: ShakeOptions -> [CmdOption]
shakeLintWatch :: ShakeOptions -> [String]
shakeLintIgnore :: ShakeOptions -> [String]
shakeLintInside :: ShakeOptions -> [String]
shakeLint :: ShakeOptions -> Maybe Lint
shakeReport :: ShakeOptions -> [String]
shakeStaunch :: ShakeOptions -> Bool
shakeVerbosity :: ShakeOptions -> Verbosity
shakeVersion :: ShakeOptions -> String
shakeThreads :: ShakeOptions -> Int
shakeFiles :: ShakeOptions -> String
..} IO String -> IO ()
diagnostic HashMap k (Ver, BinaryOp v)
witness = do
    let lockFile :: String
lockFile = String
shakeFiles String -> 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
$ String
"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 String
"After usingLockFile"

    let dbfile :: String
dbfile = String
shakeFiles String -> String -> String
</> String
".shake.database"
    String -> IO ()
createDirectoryRecursive String
shakeFiles

    -- complete a partially failed compress
    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 String
"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 String
"Backup file move to original"

    String -> IO ()
addTiming String
"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
<.> 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
$ String
"Backup of corrupted file stored at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"

    -- check the version information matches
    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
+ Int
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 ByteString
_ -> 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 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) (\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 ByteString
bs = String
"[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 -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                            [[Char
'0' | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
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 String
""]
            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 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
> Integer
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
$ String
"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]
++ String
" 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
$ String
"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]
++ String
" 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]
++ String
" slop"
                            a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
i
                        Right ByteString
bs | (Id
id, Just (k
k,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 a
x) = String
"FAILURE: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x
                                    pretty (Right 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
`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
$ String
"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 -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
raw ByteString
bs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " 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 -> 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
+a
1
                        Right 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
$ String
"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 -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
raw ByteString
bs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" UNKNOWN WITNESS"
                            a -> IO a
go a
i
            Int
countItems <- Int -> IO Int
forall a. (Show a, Num a) => a -> IO a
go Int
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
$ String
"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]
++ String
" 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
*Int
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 String
"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
$ \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
$ \Id
i (k
k,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 v
ids -> Ids v -> IO (Ids v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ids v
ids
        Maybe (Ids v)
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 String
"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 Id
i 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 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
</> String
".shake.storage.log") (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\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 -> String
forall a. [a] -> [a] -> [a]
++ String -> String
trimEnd String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
        outputErr :: [String] -> IO ()
outputErr [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


-- | A list oft witnesses, saved
type Witnesses = BS.ByteString

-- | The version and key, serialised
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 Int
v) 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
== Int
0 then String
"" else String
", 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 [Witness]
xs = [ByteString] -> Builder
forall a. BinaryEx a => a -> Builder
putEx [ByteString
x | Witness 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


-- | Given the current witness table, and the serialised one from last time, return
--   (witnesses that got removed, way to deserialise an entry into an Id, and (if the witness remains) the key and value)
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 HashMap k (Ver, BinaryOp v)
mp 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))
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
$ \ByteString
bs ->
            let (Word16
wInd :: Word16, Id
i :: Id, 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
                    Maybe (ByteString -> Maybe (k, v))
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
$ String
"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 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 | (Int
i, Witness ByteString
w) <- Int -> [Witness] -> [(Int, Witness)]
forall a b. Enum a => a -> [b] -> [(a, b)]
zipFrom Int
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,(Ver
ver,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))
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
$ \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
                Maybe (k, BinaryOp v)
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, BinaryOp{v -> Builder
ByteString -> v
getOp :: forall v. BinaryOp v -> ByteString -> v
putOp :: forall v. BinaryOp v -> v -> Builder
getOp :: ByteString -> v
putOp :: v -> Builder
..}) -> \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 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
$ String
"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
`seq` \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
$ String
"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
        -- the entries in the witness table (in a stable order, to make it more likely to get a good equality)
        [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,(Ver
ver,BinaryOp v
_)) -> 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

        -- an index for each of the witness entries
        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 [Word16
0 :: Word16 ..]

        -- the save functions
        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 (Ver
ver,BinaryOp{v -> Builder
ByteString -> v
getOp :: ByteString -> v
putOp :: v -> Builder
getOp :: forall v. BinaryOp v -> ByteString -> v
putOp :: forall v. BinaryOp v -> v -> Builder
..}) ->
                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, Partial) => HashMap k v -> k -> v
Map.! Ver -> k -> Witness
forall k. Show k => Ver -> k -> Witness
toWitness Ver
ver k
k
                in \(Id Word32
w) 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