    {-# 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 Int
    25 (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $ String
    "HOOGLE-" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Version -> String
    showVersion (Int -> Version -> Version
    trimVersion Int
    3 Version
    version) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Char -> String
    forall a. a -> [a]
    repeat Char
    ' '

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

    intSize :: Int
    intSize :: Int
    intSize = Int
    4

    intToBS :: Int -> BS.ByteString
    intToBS :: Int -> ByteString
    intToBS 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 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 :: forall a. Binary a => a -> ByteString
    encodeBS = LazyByteString -> ByteString
    LBS.toStrict (LazyByteString -> ByteString)
    -> (a -> LazyByteString) -> a -> ByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> LazyByteString
    forall a. Binary a => a -> LazyByteString
    encode

    decodeBS :: Binary a => BS.ByteString -> a
    decodeBS :: forall a. Binary a => ByteString -> a
    decodeBS = LazyByteString -> a
    forall a. Binary a => LazyByteString -> a
    decode (LazyByteString -> a)
    -> (ByteString -> LazyByteString) -> ByteString -> a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> LazyByteString
    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
    $cshowsPrec :: Int -> Atom -> String -> String
    showsPrec :: Int -> Atom -> String -> String
    $cshow :: Atom -> String
    show :: Atom -> String
    $cshowList :: [Atom] -> String -> String
    showList :: [Atom] -> String -> String
    Show

    instance Binary Atom where
        put :: Atom -> Put
    put (Atom String
    a Int
    b Int
    c) = String -> Put
    forall t. Binary t => t -> Put
    put String
    a Put -> Put -> Put
    forall a b. PutM a -> PutM b -> PutM b
    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 a b. PutM a -> PutM b -> PutM b
    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 :: forall (t :: * -> *).
    Typeable (t ByteString) =>
    StoreWrite -> t ByteString -> Bool -> ByteString -> IO ()
    storedWrite StoreWrite
    store t ByteString
    k Bool
    part 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
    $ \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 :: forall (t :: * -> *).
    Typeable (t ByteString) =>
    StoreRead -> t ByteString -> ByteString
    storedRead StoreRead
    store 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 :: forall (t :: * -> *).
    Typeable (t (Vector a)) =>
    StoreWrite -> t (Vector a) -> Bool -> Vector a -> IO ()
    storedWrite StoreWrite
    store t (Vector a)
    k Bool
    part 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 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 :: forall (t :: * -> *).
    Typeable (t (Vector a)) =>
    StoreRead -> t (Vector a) -> Vector a
    storedRead StoreRead
    store 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 CChar
    ptr, Int
    len) -> do
            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
            pure $ V.unsafeFromForeignPtr0 ptr (len `div` sizeOf (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 :: forall a. String -> (StoreWrite -> IO a) -> IO ([String], a)
    storeWriteFile String
    file StoreWrite -> IO a
    act = do
        atoms <- Map (ZonkAny 0) (ZonkAny 1)
    -> IO (IORef (Map (ZonkAny 0) (ZonkAny 1)))
    forall a. a -> IO (IORef a)
    newIORef Map (ZonkAny 0) (ZonkAny 1)
    forall k a. Map k a
    Map.empty
        parts <- newIORef Nothing
        withBinaryFile file WriteMode $ \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
            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) []
            res <- act $ StoreWrite ref
            SW{..} <- readIORef ref

            -- sort the atoms and validate there are no duplicates
            let atoms = [(String, Atom)] -> Map String Atom
    forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList [(String, Atom)]
    swAtoms
            when (Map.size atoms /= length swAtoms) $
                errorIO $ "Some duplicate names have been written out: " ++ show (length swAtoms - Map.size atoms) ++ " duplicates"

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

            final <- hTell h
            let stats = Int -> String -> [(String, Double)] -> [String]
    prettyTable Int
    0 String
    "Bytes" ([(String, Double)] -> [String]) -> [(String, Double)] -> [String]
    forall a b. (a -> b) -> a -> b
    $
                    (String
    "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 a. Num a => [a] -> a
    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 -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    atomType, Int -> Double
    intToDouble Int
    atomSize) | (String
    name, Atom{Int
    String
    atomType :: Atom -> String
    atomPosition :: Atom -> Int
    atomSize :: Atom -> Int
    atomType :: String
    atomSize :: Int
    atomPosition :: Int
    ..}) <- Map String Atom -> [(String, Atom)]
    forall k a. Map k a -> [(k, a)]
    Map.toList Map String Atom
    atoms]
            pure (stats, res)

    storeWrite :: (Typeable (t a), Typeable a, Stored a) => StoreWrite -> t a -> a -> IO ()
    storeWrite :: forall (t :: * -> *) a.
    (Typeable (t a), Typeable a, Stored a) =>
    StoreWrite -> t a -> a -> IO ()
    storeWrite StoreWrite
    store t a
    k = StoreWrite -> t a -> Bool -> a -> IO ()
    forall a (t :: * -> *).
    (Stored a, Typeable (t a)) =>
    StoreWrite -> t a -> Bool -> a -> IO ()
    forall (t :: * -> *).
    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 :: forall (t :: * -> *) a.
    (Typeable (t a), Typeable a, Stored a) =>
    StoreWrite -> t a -> a -> IO ()
    storeWritePart StoreWrite
    store t a
    k = StoreWrite -> t a -> Bool -> a -> IO ()
    forall a (t :: * -> *).
    (Stored a, Typeable (t a)) =>
    StoreWrite -> t a -> Bool -> a -> IO ()
    forall (t :: * -> *).
    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 Handle
    a Ptr a
    b 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 :: forall (t :: * -> *) a.
    (Typeable (t a), Typeable a) =>
    StoreWrite -> t a -> Bool -> CStringLen -> IO ()
    storeWriteAtom (StoreWrite 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) Bool
    part (Ptr CChar
    ptr, Int
    len) = do
        sw@SW{..} <- IORef SW -> IO SW
    forall a. IORef a -> IO a
    readIORef IORef SW
    ref
        putBuffer swHandle ptr len

        let 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)
        atoms <- case swAtoms of
            (String
    keyOld,Atom
    a):[(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 a. a -> IO a
    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=size}) (String, Atom) -> [(String, Atom)] -> [(String, Atom)]
    forall a. a -> [a] -> [a]
    : [(String, Atom)]
    xs
            [(String, Atom)]
    _ -> [(String, Atom)] -> IO [(String, Atom)]
    forall a. a -> IO a
    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
        writeIORef' ref sw{swPosition = swPosition + len, swAtoms = 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 :: forall a. NFData a => String -> (StoreRead -> IO a) -> IO a
    storeReadFile String
    file 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, 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
    * Int
    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
    $ String
    "The Hoogle file " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    file String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " 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]
    ++ String
    " bytes."

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

        atomSize <- intFromBS <$> BS.unsafePackCStringLen (plusPtr ptr $ len - verN - intSize, intSize)
        when (len < verN + intSize + atomSize) $
            errorIO $ "The Hoogle file " ++ file ++ " is corrupt, couldn't read atom table."
        atoms <- decodeBS <$> BS.unsafePackCStringLen (plusPtr ptr $ len - verN - intSize - atomSize, atomSize)
        act $ StoreRead file len ptr atoms

    storeRead :: (Typeable (t a), Typeable a, Stored a) => StoreRead -> t a -> a
    storeRead :: forall (t :: * -> *) a.
    (Typeable (t a), Typeable a, Stored a) =>
    StoreRead -> t a -> a
    storeRead = StoreRead -> t a -> a
    forall a (t :: * -> *).
    (Stored a, Typeable (t a)) =>
    StoreRead -> t a -> a
    forall (t :: * -> *). 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 :: forall a (t :: * -> *).
    (Typeable (t a), Typeable a) =>
    StoreRead -> t a -> (CStringLen -> IO a) -> a
    storeReadAtom StoreRead{Int
    String
    Ptr ()
    Map String Atom
    srFile :: StoreRead -> String
    srLen :: StoreRead -> Int
    srPtr :: StoreRead -> Ptr ()
    srAtoms :: StoreRead -> Map String Atom
    srFile :: String
    srLen :: Int
    srPtr :: Ptr ()
    srAtoms :: Map String Atom
    ..} (t a -> TypeRep
    forall a. Typeable a => a -> TypeRep
    typeOf -> TypeRep
    k) 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 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
    $ String
    "The Hoogle file " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    srFile String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " is corrupt, " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    key String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    msg String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "."
        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
            Maybe Atom
    Nothing -> String -> IO a
    corrupt String
    "is missing"
            Just Atom{Int
    String
    atomType :: Atom -> String
    atomPosition :: Atom -> Int
    atomSize :: Atom -> Int
    atomType :: String
    atomPosition :: Int
    atomSize :: Int
    ..}
                | 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
    $ String
    "has type " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    atomType String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ", expected " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    val
                | Int
    atomPosition Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    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 String
    "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 :: forall (t :: * -> *).
    Typeable (t (a, b)) =>
    StoreWrite -> t (a, b) -> Bool -> (a, b) -> IO ()
    storedWrite StoreWrite
    store t (a, b)
    k Bool
    False (a
    a,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 a b. IO a -> IO b -> IO b
    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 :: forall (t :: * -> *).
    Typeable (t (a, b)) =>
    StoreRead -> t (a, b) -> (a, b)
    storedRead StoreRead
    store 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 :: forall (t :: * -> *).
    Typeable (t Int) =>
    StoreWrite -> t Int -> Bool -> Int -> IO ()
    storedWrite StoreWrite
    store t Int
    k Bool
    False 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 :: forall (t :: * -> *). Typeable (t Int) => StoreRead -> t Int -> Int
    storedRead StoreRead
    store 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 :: forall a. Storable a => [[a]] -> Jagged a
    jaggedFromList [[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
    (+) Word32
    0 ([Word32] -> [Word32]) -> [Word32] -> [Word32]
    forall a b. (a -> b) -> a -> b
    $ ([a] -> Word32) -> [[a]] -> [Word32]
    forall a b. (a -> b) -> [a] -> [b]
    map (\[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 a. [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 :: forall a. Storable a => Jagged a -> Int -> Vector a
    jaggedAsk (Jagged Vector Word32
    is Vector a
    vs) 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 :: forall (t :: * -> *).
    Typeable (t (Jagged a)) =>
    StoreWrite -> t (Jagged a) -> Bool -> Jagged a -> IO ()
    storedWrite StoreWrite
    store t (Jagged a)
    k Bool
    False (Jagged Vector Word32
    is 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 :: forall (t :: * -> *).
    Typeable (t (Jagged a)) =>
    StoreRead -> t (Jagged a) -> Jagged a
    storedRead StoreRead
    store 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