{-# 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 :: 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 String
a Int
b 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 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 :: 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 :: 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 :: 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
        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 String
file 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
$ \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{Int
[(String, Atom)]
Handle
swAtoms :: [(String, Atom)]
swPosition :: Int
swHandle :: Handle
swAtoms :: SW -> [(String, Atom)]
swPosition :: SW -> Int
swHandle :: SW -> Handle
..} <- 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
$ String
"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]
++ String
" 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 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 (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
atomPosition :: Int
atomSize :: Int
atomType :: String
atomSize :: Atom -> Int
atomPosition :: Atom -> Int
atomType :: Atom -> String
..}) <- 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 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 ()
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 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 ()
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 :: 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
sw@SW{Int
[(String, Atom)]
Handle
swAtoms :: [(String, Atom)]
swPosition :: Int
swHandle :: Handle
swAtoms :: SW -> [(String, Atom)]
swPosition :: SW -> Int
swHandle :: SW -> Handle
..} <- 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
        (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 (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)]
_ -> [(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 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
    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 Int
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
$ String
"The Hoogle file " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is the wrong version or format.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                      String
"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]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                      String
"Got     : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (\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` String
"_-. " then Char
x else Char
'?') (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
$ String
"The Hoogle file " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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
$ 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, 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{Int
String
Ptr ()
Map String Atom
srAtoms :: Map String Atom
srPtr :: Ptr ()
srLen :: Int
srFile :: String
srAtoms :: StoreRead -> Map String Atom
srPtr :: StoreRead -> Ptr ()
srLen :: StoreRead -> Int
srFile :: StoreRead -> String
..} (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
atomSize :: Int
atomPosition :: Int
atomType :: String
atomSize :: Atom -> Int
atomPosition :: Atom -> Int
atomType :: Atom -> String
..}
            | 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 :: 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 (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 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 :: 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 :: 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 :: [[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 (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 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 :: 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 :: 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