    {-# LANGUAGE DeriveDataTypeable, GADTs, PatternGuards, RecordWildCards,
                 ScopedTypeVariables, ViewPatterns #-}

    module General.Store(
        Typeable, Stored,
        intSize, intFromBS, intToBS, encodeBS, decodeBS,
        StoreWrite, storeWriteFile, storeWrite, storeWritePart,
        StoreRead, storeReadFile, storeRead,
        Jagged, jaggedFromList, jaggedAsk,
        ) where

    import Control.Applicative
    import Control.DeepSeq
    import Control.Exception
    import Control.Exception.Extra
    import Control.Monad.Extra
    import Data.Binary
    import qualified Data.ByteString.Char8 as BS
    import qualified Data.ByteString.Lazy as LBS
    import qualified Data.ByteString.Unsafe as BS
    import Data.Char
    import Data.IORef.Extra
    import Data.List.Extra
    import qualified Data.Map as Map
    import Data.Typeable
    import qualified Data.Vector.Storable as V
    import Data.Version
    import Foreign.C.String
    import Foreign.ForeignPtr
    import Foreign.Ptr
    import Foreign.Storable
    import General.Util
    import Numeric.Extra
    import Paths_hoogle
    import Prelude
    import System.IO.Extra
    import System.IO.MMap
    import System.IO.Unsafe

    -- Ensure the string is always 25 chars long, so version numbers don't change its size
    -- Only use the first two components of the version number to identify the database
    verString :: ByteString
    verString = String -> ByteString
    BS.pack (String -> ByteString) -> String -> ByteString
    forall a b. (a -> b) -> a -> b
    $ Int -> String -> String
    forall a. Int -> [a] -> [a]
    take 25 (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $ "HOOGLE-" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Version -> String
    showVersion (Int -> Version -> Version
    trimVersion 3 Version
    version) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Char -> String
    forall a. a -> [a]
    repeat ' '

    ---------------------------------------------------------------------
    -- SERIALISATION HELPERS

    intSize :: Int
    intSize :: Int
    intSize = 4

    intToBS :: Int -> BS.ByteString
    intToBS :: Int -> ByteString
    intToBS i :: Int
    i = Word32 -> ByteString
    forall a. Binary a => a -> ByteString
    encodeBS (Int -> Word32
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    i :: Word32)

    intFromBS :: BS.ByteString -> Int
    intFromBS :: ByteString -> Int
    intFromBS bs :: ByteString
    bs = Word32 -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (ByteString -> Word32
    forall a. Binary a => ByteString -> a
    decodeBS ByteString
    bs :: Word32)

    encodeBS :: Binary a => a -> BS.ByteString
    encodeBS :: a -> ByteString
    encodeBS = ByteString -> ByteString
    LBS.toStrict (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> ByteString
    forall a. Binary a => a -> ByteString
    encode

    decodeBS :: Binary a => BS.ByteString -> a
    decodeBS :: ByteString -> a
    decodeBS = ByteString -> a
    forall a. Binary a => ByteString -> a
    decode (ByteString -> a) -> (ByteString -> ByteString) -> ByteString -> a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> ByteString
    LBS.fromStrict

    ---------------------------------------------------------------------
    -- TREE INDEX STRUCTURE

    -- each atom name is either unique (a scope) or "" (a list entry)
    data Atom = Atom
        {Atom -> String
    atomType :: String -- Type that the atom contains (for sanity checking)
        ,Atom -> Int
    atomPosition :: {-# UNPACK #-} !Int -- Position at which the atom starts in the file
        ,Atom -> Int
    atomSize :: {-# UNPACK #-} !Int -- Number of bytes the value takes up
        } deriving Int -> Atom -> String -> String
    [Atom] -> String -> String
    Atom -> String
    (Int -> Atom -> String -> String)
    -> (Atom -> String) -> ([Atom] -> String -> String) -> Show Atom
    forall a.
    (Int -> a -> String -> String)
    -> (a -> String) -> ([a] -> String -> String) -> Show a
    showList :: [Atom] -> String -> String
    $cshowList :: [Atom] -> String -> String
    show :: Atom -> String
    $cshow :: Atom -> String
    showsPrec :: Int -> Atom -> String -> String
    $cshowsPrec :: Int -> Atom -> String -> String
    Show

    instance Binary Atom where
        put :: Atom -> Put
    put (Atom a :: String
    a b :: Int
    b c :: Int
    c) = String -> Put
    forall t. Binary t => t -> Put
    put String
    a Put -> Put -> Put
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Int -> Put
    forall t. Binary t => t -> Put
    put Int
    b Put -> Put -> Put
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Int -> Put
    forall t. Binary t => t -> Put
    put Int
    c
        get :: Get Atom
    get = (String -> Int -> Int -> Atom)
    -> Get String -> Get Int -> Get Int -> Get Atom
    forall (f :: * -> *) a b c d.
    Applicative f =>
    (a -> b -> c -> d) -> f a -> f b -> f c -> f d
    liftA3 String -> Int -> Int -> Atom
    Atom Get String
    forall t. Binary t => Get t
    get Get Int
    forall t. Binary t => Get t
    get Get Int
    forall t. Binary t => Get t
    get

    ---------------------------------------------------------------------
    -- TYPE CLASS

    class Typeable a => Stored a where
        storedWrite :: Typeable (t a) => StoreWrite -> t a -> Bool -> a -> IO ()
        storedRead :: Typeable (t a) => StoreRead -> t a -> a

    instance Stored BS.ByteString where
        storedWrite :: StoreWrite -> t ByteString -> Bool -> ByteString -> IO ()
    storedWrite store :: StoreWrite
    store k :: t ByteString
    k part :: Bool
    part v :: ByteString
    v = ByteString -> (CStringLen -> IO ()) -> IO ()
    forall a. ByteString -> (CStringLen -> IO a) -> IO a
    BS.unsafeUseAsCStringLen ByteString
    v ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \x :: CStringLen
    x -> StoreWrite -> t ByteString -> Bool -> CStringLen -> IO ()
    forall (t :: * -> *) a.
    (Typeable (t a), Typeable a) =>
    StoreWrite -> t a -> Bool -> CStringLen -> IO ()
    storeWriteAtom StoreWrite
    store t ByteString
    k Bool
    part CStringLen
    x
        storedRead :: StoreRead -> t ByteString -> ByteString
    storedRead store :: StoreRead
    store k :: t ByteString
    k = StoreRead
    -> t ByteString -> (CStringLen -> IO ByteString) -> ByteString
    forall a (t :: * -> *).
    (Typeable (t a), Typeable a) =>
    StoreRead -> t a -> (CStringLen -> IO a) -> a
    storeReadAtom StoreRead
    store t ByteString
    k CStringLen -> IO ByteString
    BS.unsafePackCStringLen

    instance forall a . (Typeable a, Storable a) => Stored (V.Vector a) where
        storedWrite :: StoreWrite -> t (Vector a) -> Bool -> Vector a -> IO ()
    storedWrite store :: StoreWrite
    store k :: t (Vector a)
    k part :: Bool
    part v :: Vector a
    v = Vector a -> (Ptr a -> IO ()) -> IO ()
    forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
    V.unsafeWith Vector a
    v ((Ptr a -> IO ()) -> IO ()) -> (Ptr a -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \ptr :: Ptr a
    ptr ->
            StoreWrite -> t (Vector a) -> Bool -> CStringLen -> IO ()
    forall (t :: * -> *) a.
    (Typeable (t a), Typeable a) =>
    StoreWrite -> t a -> Bool -> CStringLen -> IO ()
    storeWriteAtom StoreWrite
    store t (Vector a)
    k Bool
    part (Ptr a -> Ptr CChar
    forall a b. Ptr a -> Ptr b
    castPtr Ptr a
    ptr, Vector a -> Int
    forall a. Storable a => Vector a -> Int
    V.length Vector a
    v Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * a -> Int
    forall a. Storable a => a -> Int
    sizeOf (a
    forall a. HasCallStack => a
    undefined :: a))
        storedRead :: StoreRead -> t (Vector a) -> Vector a
    storedRead store :: StoreRead
    store k :: t (Vector a)
    k = StoreRead
    -> t (Vector a) -> (CStringLen -> IO (Vector a)) -> Vector a
    forall a (t :: * -> *).
    (Typeable (t a), Typeable a) =>
    StoreRead -> t a -> (CStringLen -> IO a) -> a
    storeReadAtom StoreRead
    store t (Vector a)
    k ((CStringLen -> IO (Vector a)) -> Vector a)
    -> (CStringLen -> IO (Vector a)) -> Vector a
    forall a b. (a -> b) -> a -> b
    $ \(ptr :: Ptr CChar
    ptr, len :: Int
    len) -> do
            ForeignPtr a
    ptr <- Ptr a -> IO (ForeignPtr a)
    forall a. Ptr a -> IO (ForeignPtr a)
    newForeignPtr_ (Ptr a -> IO (ForeignPtr a)) -> Ptr a -> IO (ForeignPtr a)
    forall a b. (a -> b) -> a -> b
    $ Ptr CChar -> Ptr a
    forall a b. Ptr a -> Ptr b
    castPtr Ptr CChar
    ptr
            Vector a -> IO (Vector a)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Vector a -> IO (Vector a)) -> Vector a -> IO (Vector a)
    forall a b. (a -> b) -> a -> b
    $ ForeignPtr a -> Int -> Vector a
    forall a. Storable a => ForeignPtr a -> Int -> Vector a
    V.unsafeFromForeignPtr0 ForeignPtr a
    ptr (Int
    len Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `div` a -> Int
    forall a. Storable a => a -> Int
    sizeOf (a
    forall a. HasCallStack => a
    undefined :: a))

    ---------------------------------------------------------------------
    -- WRITE OUT

    data SW = SW
        {SW -> Handle
    swHandle :: Handle -- Immutable handle I write to
        ,SW -> Int
    swPosition :: !Int -- Position within swHandle
        ,SW -> [(String, Atom)]
    swAtoms :: [(String, Atom)] -- List of pieces, in reverse
        }

    newtype StoreWrite = StoreWrite (IORef SW)

    storeWriteFile :: FilePath -> (StoreWrite -> IO a) -> IO ([String], a)
    storeWriteFile :: String -> (StoreWrite -> IO a) -> IO ([String], a)
    storeWriteFile file :: String
    file act :: StoreWrite -> IO a
    act = do
        IORef (Map Any Any)
    atoms <- Map Any Any -> IO (IORef (Map Any Any))
    forall a. a -> IO (IORef a)
    newIORef Map Any Any
    forall k a. Map k a
    Map.empty
        IORef (Maybe Any)
    parts <- Maybe Any -> IO (IORef (Maybe Any))
    forall a. a -> IO (IORef a)
    newIORef Maybe Any
    forall a. Maybe a
    Nothing
        String
    -> IOMode -> (Handle -> IO ([String], a)) -> IO ([String], a)
    forall r. String -> IOMode -> (Handle -> IO r) -> IO r
    withBinaryFile String
    file IOMode
    WriteMode ((Handle -> IO ([String], a)) -> IO ([String], a))
    -> (Handle -> IO ([String], a)) -> IO ([String], a)
    forall a b. (a -> b) -> a -> b
    $ \h :: Handle
    h -> do
            -- put the version string at the start and end, so we can tell truncation vs wrong version
            Handle -> ByteString -> IO ()
    BS.hPut Handle
    h ByteString
    verString
            IORef SW
    ref <- SW -> IO (IORef SW)
    forall a. a -> IO (IORef a)
    newIORef (SW -> IO (IORef SW)) -> SW -> IO (IORef SW)
    forall a b. (a -> b) -> a -> b
    $ Handle -> Int -> [(String, Atom)] -> SW
    SW Handle
    h (ByteString -> Int
    BS.length ByteString
    verString) []
            a
    res <- StoreWrite -> IO a
    act (StoreWrite -> IO a) -> StoreWrite -> IO a
    forall a b. (a -> b) -> a -> b
    $ IORef SW -> StoreWrite
    StoreWrite IORef SW
    ref
            SW{..} <- IORef SW -> IO SW
    forall a. IORef a -> IO a
    readIORef IORef SW
    ref

            -- sort the atoms and validate there are no duplicates
            let atoms :: Map String Atom
    atoms = [(String, Atom)] -> Map String Atom
    forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList [(String, Atom)]
    swAtoms
            Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Map String Atom -> Int
    forall k a. Map k a -> Int
    Map.size Map String Atom
    atoms Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    /= [(String, Atom)] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [(String, Atom)]
    swAtoms) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
                String -> IO ()
    forall a. HasCallStack => String -> IO a
    errorIO (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ "Some duplicate names have been written out: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show ([(String, Atom)] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [(String, Atom)]
    swAtoms Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Map String Atom -> Int
    forall k a. Map k a -> Int
    Map.size Map String Atom
    atoms) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " duplicates"

            -- write the atoms out, then put the size at the end
            let bs :: ByteString
    bs = Map String Atom -> ByteString
    forall a. Binary a => a -> ByteString
    encodeBS Map String Atom
    atoms
            Handle -> ByteString -> IO ()
    BS.hPut Handle
    h ByteString
    bs
            Handle -> ByteString -> IO ()
    BS.hPut Handle
    h (ByteString -> IO ()) -> ByteString -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Int -> ByteString
    intToBS (Int -> ByteString) -> Int -> ByteString
    forall a b. (a -> b) -> a -> b
    $ ByteString -> Int
    BS.length ByteString
    bs
            Handle -> ByteString -> IO ()
    BS.hPut Handle
    h ByteString
    verString

            Integer
    final <- Handle -> IO Integer
    hTell Handle
    h
            let stats :: [String]
    stats = Int -> String -> [(String, Double)] -> [String]
    prettyTable 0 "Bytes" ([(String, Double)] -> [String]) -> [(String, Double)] -> [String]
    forall a b. (a -> b) -> a -> b
    $
                    ("Overheads", Int -> Double
    intToDouble (Int -> Double) -> Int -> Double
    forall a b. (a -> b) -> a -> b
    $ Integer -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Integer
    final Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - [Int] -> Int
    forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    sum ((Atom -> Int) -> [Atom] -> [Int]
    forall a b. (a -> b) -> [a] -> [b]
    map Atom -> Int
    atomSize ([Atom] -> [Int]) -> [Atom] -> [Int]
    forall a b. (a -> b) -> a -> b
    $ Map String Atom -> [Atom]
    forall k a. Map k a -> [a]
    Map.elems Map String Atom
    atoms)) (String, Double) -> [(String, Double)] -> [(String, Double)]
    forall a. a -> [a] -> [a]
    :
                    [(String
    name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " :: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    atomType, Int -> Double
    intToDouble Int
    atomSize) | (name :: String
    name, Atom{..}) <- Map String Atom -> [(String, Atom)]
    forall k a. Map k a -> [(k, a)]
    Map.toList Map String Atom
    atoms]
            ([String], a) -> IO ([String], a)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ([String]
    stats, a
    res)

    storeWrite :: (Typeable (t a), Typeable a, Stored a) => StoreWrite -> t a -> a -> IO ()
    storeWrite :: StoreWrite -> t a -> a -> IO ()
    storeWrite store :: StoreWrite
    store k :: t a
    k = StoreWrite -> t a -> Bool -> a -> IO ()
    forall a (t :: * -> *).
    (Stored a, Typeable (t a)) =>
    StoreWrite -> t a -> Bool -> a -> IO ()
    storedWrite StoreWrite
    store t a
    k Bool
    False

    storeWritePart :: forall t a . (Typeable (t a), Typeable a, Stored a) => StoreWrite -> t a -> a -> IO ()
    storeWritePart :: StoreWrite -> t a -> a -> IO ()
    storeWritePart store :: StoreWrite
    store k :: t a
    k = StoreWrite -> t a -> Bool -> a -> IO ()
    forall a (t :: * -> *).
    (Stored a, Typeable (t a)) =>
    StoreWrite -> t a -> Bool -> a -> IO ()
    storedWrite StoreWrite
    store t a
    k Bool
    True

    {-# NOINLINE putBuffer #-}
    putBuffer :: Handle -> Ptr a -> Int -> IO ()
    putBuffer a :: Handle
    a b :: Ptr a
    b c :: Int
    c = Handle -> Ptr a -> Int -> IO ()
    forall a. Handle -> Ptr a -> Int -> IO ()
    hPutBuf Handle
    a Ptr a
    b Int
    c

    storeWriteAtom :: forall t a . (Typeable (t a), Typeable a) => StoreWrite -> t a -> Bool -> CStringLen -> IO ()
    storeWriteAtom :: StoreWrite -> t a -> Bool -> CStringLen -> IO ()
    storeWriteAtom (StoreWrite ref :: IORef SW
    ref) (TypeRep -> String
    forall a. Show a => a -> String
    show (TypeRep -> String) -> (t a -> TypeRep) -> t a -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . t a -> TypeRep
    forall a. Typeable a => a -> TypeRep
    typeOf -> String
    key) part :: Bool
    part (ptr :: Ptr CChar
    ptr, len :: Int
    len) = do
        sw :: SW
    sw@SW{..} <- IORef SW -> IO SW
    forall a. IORef a -> IO a
    readIORef IORef SW
    ref
        Handle -> Ptr CChar -> Int -> IO ()
    forall a. Handle -> Ptr a -> Int -> IO ()
    putBuffer Handle
    swHandle Ptr CChar
    ptr Int
    len

        let val :: String
    val = TypeRep -> String
    forall a. Show a => a -> String
    show (TypeRep -> String) -> TypeRep -> String
    forall a b. (a -> b) -> a -> b
    $ Proxy a -> TypeRep
    forall k (proxy :: k -> *) (a :: k).
    Typeable a =>
    proxy a -> TypeRep
    typeRep (Proxy a
    forall k (t :: k). Proxy t
    Proxy :: Proxy a)
        [(String, Atom)]
    atoms <- case [(String, Atom)]
    swAtoms of
            (keyOld :: String
    keyOld,a :: Atom
    a):xs :: [(String, Atom)]
    xs | Bool
    part, String
    key String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == String
    keyOld -> do
                let size :: Int
    size = Atom -> Int
    atomSize Atom
    a Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    len
                Int -> IO Int
    forall a. a -> IO a
    evaluate Int
    size
                [(String, Atom)] -> IO [(String, Atom)]
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ([(String, Atom)] -> IO [(String, Atom)])
    -> [(String, Atom)] -> IO [(String, Atom)]
    forall a b. (a -> b) -> a -> b
    $ (String
    key,Atom
    a{atomSize :: Int
    atomSize=Int
    size}) (String, Atom) -> [(String, Atom)] -> [(String, Atom)]
    forall a. a -> [a] -> [a]
    : [(String, Atom)]
    xs
            _ -> [(String, Atom)] -> IO [(String, Atom)]
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ([(String, Atom)] -> IO [(String, Atom)])
    -> [(String, Atom)] -> IO [(String, Atom)]
    forall a b. (a -> b) -> a -> b
    $ (String
    key, String -> Int -> Int -> Atom
    Atom String
    val Int
    swPosition Int
    len) (String, Atom) -> [(String, Atom)] -> [(String, Atom)]
    forall a. a -> [a] -> [a]
    : [(String, Atom)]
    swAtoms
        IORef SW -> SW -> IO ()
    forall a. IORef a -> a -> IO ()
    writeIORef' IORef SW
    ref SW
    sw{swPosition :: Int
    swPosition = Int
    swPosition Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    len, swAtoms :: [(String, Atom)]
    swAtoms = [(String, Atom)]
    atoms}

    ---------------------------------------------------------------------
    -- READ OUT

    data StoreRead = StoreRead
        {StoreRead -> String
    srFile :: FilePath
        ,StoreRead -> Int
    srLen :: Int
        ,StoreRead -> Ptr ()
    srPtr :: Ptr ()
        ,StoreRead -> Map String Atom
    srAtoms :: Map.Map String Atom
        }

    storeReadFile :: NFData a => FilePath -> (StoreRead -> IO a) -> IO a
    storeReadFile :: String -> (StoreRead -> IO a) -> IO a
    storeReadFile file :: String
    file act :: StoreRead -> IO a
    act = String
    -> Mode -> Maybe (Int64, Int) -> ((Ptr (), Int) -> IO a) -> IO a
    forall a.
    String
    -> Mode -> Maybe (Int64, Int) -> ((Ptr (), Int) -> IO a) -> IO a
    mmapWithFilePtr String
    file Mode
    ReadOnly Maybe (Int64, Int)
    forall a. Maybe a
    Nothing (((Ptr (), Int) -> IO a) -> IO a)
    -> ((Ptr (), Int) -> IO a) -> IO a
    forall a b. (a -> b) -> a -> b
    $ \(ptr :: Ptr ()
    ptr, len :: Int
    len) -> IO a -> IO a
    forall a. NFData a => IO a -> IO a
    strict (IO a -> IO a) -> IO a -> IO a
    forall a b. (a -> b) -> a -> b
    $ do
        -- check is longer than my version string
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Int
    len Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < (ByteString -> Int
    BS.length ByteString
    verString Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * 2) Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    intSize) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
            String -> IO ()
    forall a. HasCallStack => String -> IO a
    errorIO (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ "The Hoogle file " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    file String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " is corrupt, only " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    len String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " bytes."

        let verN :: Int
    verN = ByteString -> Int
    BS.length ByteString
    verString
        ByteString
    verEnd <- CStringLen -> IO ByteString
    BS.unsafePackCStringLen (Ptr () -> Int -> Ptr CChar
    forall a b. Ptr a -> Int -> Ptr b
    plusPtr Ptr ()
    ptr (Int -> Ptr CChar) -> Int -> Ptr CChar
    forall a b. (a -> b) -> a -> b
    $ Int
    len Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    verN, Int
    verN)
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (ByteString
    verString ByteString -> ByteString -> Bool
    forall a. Eq a => a -> a -> Bool
    /= ByteString
    verEnd) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
            ByteString
    verStart <- CStringLen -> IO ByteString
    BS.unsafePackCStringLen (Ptr () -> Int -> Ptr CChar
    forall a b. Ptr a -> Int -> Ptr b
    plusPtr Ptr ()
    ptr 0, Int
    verN)
            if ByteString
    verString ByteString -> ByteString -> Bool
    forall a. Eq a => a -> a -> Bool
    /= ByteString
    verStart then
                String -> IO ()
    forall a. HasCallStack => String -> IO a
    errorIO (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ "The Hoogle file " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    file String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " is the wrong version or format.\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                          "Expected: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    trim (ByteString -> String
    BS.unpack ByteString
    verString) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                          "Got     : " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ (Char -> Char) -> String -> String
    forall a b. (a -> b) -> [a] -> [b]
    map (\x :: Char
    x -> if Char -> Bool
    isAlphaNum Char
    x Bool -> Bool -> Bool
    || Char
    x Char -> String -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` "_-. " then Char
    x else '?') (String -> String
    trim (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $ ByteString -> String
    BS.unpack ByteString
    verStart)
             else
                String -> IO ()
    forall a. HasCallStack => String -> IO a
    errorIO (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ "The Hoogle file " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    file String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " is truncated, probably due to an error during creation."

        Int
    atomSize <- ByteString -> Int
    intFromBS (ByteString -> Int) -> IO ByteString -> IO Int
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> CStringLen -> IO ByteString
    BS.unsafePackCStringLen (Ptr () -> Int -> Ptr CChar
    forall a b. Ptr a -> Int -> Ptr b
    plusPtr Ptr ()
    ptr (Int -> Ptr CChar) -> Int -> Ptr CChar
    forall a b. (a -> b) -> a -> b
    $ Int
    len Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    verN Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    intSize, Int
    intSize)
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Int
    len Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    verN Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    intSize Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    atomSize) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
            String -> IO ()
    forall a. HasCallStack => String -> IO a
    errorIO (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ "The Hoogle file " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    file String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " is corrupt, couldn't read atom table."
        Map String Atom
    atoms <- ByteString -> Map String Atom
    forall a. Binary a => ByteString -> a
    decodeBS (ByteString -> Map String Atom)
    -> IO ByteString -> IO (Map String Atom)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> CStringLen -> IO ByteString
    BS.unsafePackCStringLen (Ptr () -> Int -> Ptr CChar
    forall a b. Ptr a -> Int -> Ptr b
    plusPtr Ptr ()
    ptr (Int -> Ptr CChar) -> Int -> Ptr CChar
    forall a b. (a -> b) -> a -> b
    $ Int
    len Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    verN Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    intSize Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    atomSize, Int
    atomSize)
        StoreRead -> IO a
    act (StoreRead -> IO a) -> StoreRead -> IO a
    forall a b. (a -> b) -> a -> b
    $ String -> Int -> Ptr () -> Map String Atom -> StoreRead
    StoreRead String
    file Int
    len Ptr ()
    ptr Map String Atom
    atoms

    storeRead :: (Typeable (t a), Typeable a, Stored a) => StoreRead -> t a -> a
    storeRead :: StoreRead -> t a -> a
    storeRead = StoreRead -> t a -> a
    forall a (t :: * -> *).
    (Stored a, Typeable (t a)) =>
    StoreRead -> t a -> a
    storedRead

    storeReadAtom :: forall a t . (Typeable (t a), Typeable a) => StoreRead -> t a -> (CStringLen -> IO a) -> a
    storeReadAtom :: StoreRead -> t a -> (CStringLen -> IO a) -> a
    storeReadAtom StoreRead{..} (t a -> TypeRep
    forall a. Typeable a => a -> TypeRep
    typeOf -> TypeRep
    k) unpack :: CStringLen -> IO a
    unpack = IO a -> a
    forall a. IO a -> a
    unsafePerformIO (IO a -> a) -> IO a -> a
    forall a b. (a -> b) -> a -> b
    $ do
        let key :: String
    key = TypeRep -> String
    forall a. Show a => a -> String
    show TypeRep
    k
        let val :: String
    val = TypeRep -> String
    forall a. Show a => a -> String
    show (TypeRep -> String) -> TypeRep -> String
    forall a b. (a -> b) -> a -> b
    $ Proxy a -> TypeRep
    forall k (proxy :: k -> *) (a :: k).
    Typeable a =>
    proxy a -> TypeRep
    typeRep (Proxy a
    forall k (t :: k). Proxy t
    Proxy :: Proxy a)
        let corrupt :: String -> IO a
    corrupt msg :: String
    msg = String -> IO a
    forall a. HasCallStack => String -> IO a
    errorIO (String -> IO a) -> String -> IO a
    forall a b. (a -> b) -> a -> b
    $ "The Hoogle file " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    srFile String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " is corrupt, " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    key String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    msg String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "."
        case String -> Map String Atom -> Maybe Atom
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup String
    key Map String Atom
    srAtoms of
            Nothing -> String -> IO a
    corrupt "is missing"
            Just Atom{..}
                | String
    atomType String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    /= String
    val -> String -> IO a
    corrupt (String -> IO a) -> String -> IO a
    forall a b. (a -> b) -> a -> b
    $ "has type " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    atomType String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ", expected " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    val
                | Int
    atomPosition Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < 0 Bool -> Bool -> Bool
    || Int
    atomPosition Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    atomSize Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    srLen -> String -> IO a
    corrupt "has incorrect bounds"
                | Bool
    otherwise -> CStringLen -> IO a
    unpack (Ptr () -> Int -> Ptr CChar
    forall a b. Ptr a -> Int -> Ptr b
    plusPtr Ptr ()
    srPtr Int
    atomPosition, Int
    atomSize)

    ---------------------------------------------------------------------
    -- PAIRS

    newtype Fst k v where Fst :: k -> Fst k a deriving Typeable
    newtype Snd k v where Snd :: k -> Snd k b deriving Typeable

    instance (Typeable a, Typeable b, Stored a, Stored b) => Stored (a,b) where
        storedWrite :: StoreWrite -> t (a, b) -> Bool -> (a, b) -> IO ()
    storedWrite store :: StoreWrite
    store k :: t (a, b)
    k False (a :: a
    a,b :: b
    b) = StoreWrite -> Fst (t (a, b)) a -> a -> IO ()
    forall (t :: * -> *) a.
    (Typeable (t a), Typeable a, Stored a) =>
    StoreWrite -> t a -> a -> IO ()
    storeWrite StoreWrite
    store (t (a, b) -> Fst (t (a, b)) a
    forall k a. k -> Fst k a
    Fst t (a, b)
    k) a
    a IO () -> IO () -> IO ()
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> StoreWrite -> Snd (t (a, b)) b -> b -> IO ()
    forall (t :: * -> *) a.
    (Typeable (t a), Typeable a, Stored a) =>
    StoreWrite -> t a -> a -> IO ()
    storeWrite StoreWrite
    store (t (a, b) -> Snd (t (a, b)) b
    forall k b. k -> Snd k b
    Snd t (a, b)
    k) b
    b
        storedRead :: StoreRead -> t (a, b) -> (a, b)
    storedRead store :: StoreRead
    store k :: t (a, b)
    k = (StoreRead -> Fst (t (a, b)) a -> a
    forall (t :: * -> *) a.
    (Typeable (t a), Typeable a, Stored a) =>
    StoreRead -> t a -> a
    storeRead StoreRead
    store (Fst (t (a, b)) a -> a) -> Fst (t (a, b)) a -> a
    forall a b. (a -> b) -> a -> b
    $ t (a, b) -> Fst (t (a, b)) a
    forall k a. k -> Fst k a
    Fst t (a, b)
    k, StoreRead -> Snd (t (a, b)) b -> b
    forall (t :: * -> *) a.
    (Typeable (t a), Typeable a, Stored a) =>
    StoreRead -> t a -> a
    storeRead StoreRead
    store (Snd (t (a, b)) b -> b) -> Snd (t (a, b)) b -> b
    forall a b. (a -> b) -> a -> b
    $ t (a, b) -> Snd (t (a, b)) b
    forall k b. k -> Snd k b
    Snd t (a, b)
    k)

    ---------------------------------------------------------------------
    -- LITERALS

    data StoredInt k v where StoredInt :: k -> StoredInt k BS.ByteString deriving Typeable

    instance Stored Int where
        storedWrite :: StoreWrite -> t Int -> Bool -> Int -> IO ()
    storedWrite store :: StoreWrite
    store k :: t Int
    k False v :: Int
    v = StoreWrite -> StoredInt (t Int) ByteString -> ByteString -> IO ()
    forall (t :: * -> *) a.
    (Typeable (t a), Typeable a, Stored a) =>
    StoreWrite -> t a -> a -> IO ()
    storeWrite StoreWrite
    store (t Int -> StoredInt (t Int) ByteString
    forall k. k -> StoredInt k ByteString
    StoredInt t Int
    k) (ByteString -> IO ()) -> ByteString -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Int -> ByteString
    intToBS Int
    v
        storedRead :: StoreRead -> t Int -> Int
    storedRead store :: StoreRead
    store k :: t Int
    k = ByteString -> Int
    intFromBS (ByteString -> Int) -> ByteString -> Int
    forall a b. (a -> b) -> a -> b
    $ StoreRead -> StoredInt (t Int) ByteString -> ByteString
    forall (t :: * -> *) a.
    (Typeable (t a), Typeable a, Stored a) =>
    StoreRead -> t a -> a
    storeRead StoreRead
    store (t Int -> StoredInt (t Int) ByteString
    forall k. k -> StoredInt k ByteString
    StoredInt t Int
    k)

    ---------------------------------------------------------------------
    -- JAGGED ARRAYS

    data Jagged a = Jagged (V.Vector Word32) (V.Vector a) deriving Typeable
    data JaggedStore k v where JaggedStore :: k -> JaggedStore k (V.Vector Word32, V.Vector a) deriving Typeable

    jaggedFromList :: Storable a => [[a]] -> Jagged a
    jaggedFromList :: [[a]] -> Jagged a
    jaggedFromList xs :: [[a]]
    xs = Vector Word32 -> Vector a -> Jagged a
    forall a. Vector Word32 -> Vector a -> Jagged a
    Jagged Vector Word32
    is Vector a
    vs
        where is :: Vector Word32
    is = [Word32] -> Vector Word32
    forall a. Storable a => [a] -> Vector a
    V.fromList ([Word32] -> Vector Word32) -> [Word32] -> Vector Word32
    forall a b. (a -> b) -> a -> b
    $ (Word32 -> Word32 -> Word32) -> Word32 -> [Word32] -> [Word32]
    forall b a. (b -> a -> b) -> b -> [a] -> [b]
    scanl Word32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    (+) 0 ([Word32] -> [Word32]) -> [Word32] -> [Word32]
    forall a b. (a -> b) -> a -> b
    $ ([a] -> Word32) -> [[a]] -> [Word32]
    forall a b. (a -> b) -> [a] -> [b]
    map (\x :: [a]
    x -> Int -> Word32
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Int -> Word32) -> Int -> Word32
    forall a b. (a -> b) -> a -> b
    $ [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [a]
    x :: Word32) [[a]]
    xs
              vs :: Vector a
    vs = [a] -> Vector a
    forall a. Storable a => [a] -> Vector a
    V.fromList ([a] -> Vector a) -> [a] -> Vector a
    forall a b. (a -> b) -> a -> b
    $ [[a]] -> [a]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[a]]
    xs

    jaggedAsk :: Storable a => Jagged a -> Int -> V.Vector a
    jaggedAsk :: Jagged a -> Int -> Vector a
    jaggedAsk (Jagged is :: Vector Word32
    is vs :: Vector a
    vs) i :: Int
    i = Int -> Int -> Vector a -> Vector a
    forall a. Storable a => Int -> Int -> Vector a -> Vector a
    V.slice Int
    start (Int
    end Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    start) Vector a
    vs
        where start :: Int
    start = Word32 -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word32 -> Int) -> Word32 -> Int
    forall a b. (a -> b) -> a -> b
    $ Vector Word32
    is Vector Word32 -> Int -> Word32
    forall a. Storable a => Vector a -> Int -> a
    V.! Int
    i
              end :: Int
    end   = Word32 -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word32 -> Int) -> Word32 -> Int
    forall a b. (a -> b) -> a -> b
    $ Vector Word32
    is Vector Word32 -> Int -> Word32
    forall a. Storable a => Vector a -> Int -> a
    V.! Int -> Int
    forall a. Enum a => a -> a
    succ Int
    i

    instance (Typeable a, Storable a) => Stored (Jagged a) where
        storedWrite :: StoreWrite -> t (Jagged a) -> Bool -> Jagged a -> IO ()
    storedWrite store :: StoreWrite
    store k :: t (Jagged a)
    k False (Jagged is :: Vector Word32
    is vs :: Vector a
    vs) = StoreWrite
    -> JaggedStore (t (Jagged a)) (Vector Word32, Vector a)
    -> (Vector Word32, Vector a)
    -> IO ()
    forall (t :: * -> *) a.
    (Typeable (t a), Typeable a, Stored a) =>
    StoreWrite -> t a -> a -> IO ()
    storeWrite StoreWrite
    store (t (Jagged a)
    -> JaggedStore (t (Jagged a)) (Vector Word32, Vector a)
    forall k a. k -> JaggedStore k (Vector Word32, Vector a)
    JaggedStore t (Jagged a)
    k) (Vector Word32
    is, Vector a
    vs)
        storedRead :: StoreRead -> t (Jagged a) -> Jagged a
    storedRead store :: StoreRead
    store k :: t (Jagged a)
    k = (Vector Word32 -> Vector a -> Jagged a)
    -> (Vector Word32, Vector a) -> Jagged a
    forall a b c. (a -> b -> c) -> (a, b) -> c
    uncurry Vector Word32 -> Vector a -> Jagged a
    forall a. Vector Word32 -> Vector a -> Jagged a
    Jagged ((Vector Word32, Vector a) -> Jagged a)
    -> (Vector Word32, Vector a) -> Jagged a
    forall a b. (a -> b) -> a -> b
    $ StoreRead
    -> JaggedStore (t (Jagged a)) (Vector Word32, Vector a)
    -> (Vector Word32, Vector a)
    forall (t :: * -> *) a.
    (Typeable (t a), Typeable a, Stored a) =>
    StoreRead -> t a -> a
    storeRead StoreRead
    store (JaggedStore (t (Jagged a)) (Vector Word32, Vector a)
     -> (Vector Word32, Vector a))
    -> JaggedStore (t (Jagged a)) (Vector Word32, Vector a)
    -> (Vector Word32, Vector a)
    forall a b. (a -> b) -> a -> b
    $ t (Jagged a)
    -> JaggedStore (t (Jagged a)) (Vector Word32, Vector a)
    forall k a. k -> JaggedStore k (Vector Word32, Vector a)
    JaggedStore t (Jagged a)
    k