{-# LANGUAGE ViewPatterns, TupleSections, ScopedTypeVariables, DeriveDataTypeable, ForeignFunctionInterface, GADTs #-}

module Output.Names(writeNames, searchNames) where

import Data.List.Extra
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Unsafe as BS
import qualified Data.Vector.Storable as V
import General.Str
import Foreign.Ptr
import Foreign.Marshal
import Foreign.C.String
import Foreign.C.Types
import Control.Exception
import System.IO.Unsafe
import Data.Maybe

import Input.Item
import General.Util
import General.Store

foreign import ccall text_search_bound :: CString -> IO CInt

foreign import ccall text_search :: CString -> Ptr CString -> CInt -> Ptr CInt -> IO CInt


data NamesSize a where NamesSize :: NamesSize Int deriving Typeable
data NamesItems a where NamesItems :: NamesItems (V.Vector TargetId) deriving Typeable
data NamesText a where NamesText :: NamesText BS.ByteString deriving Typeable

writeNames :: StoreWrite -> [(Maybe TargetId, Item)] -> IO ()
writeNames :: StoreWrite -> [(Maybe TargetId, Item)] -> IO ()
writeNames StoreWrite
store [(Maybe TargetId, Item)]
xs = do
    let ([TargetId]
ids, [String]
strs) = [(TargetId, String)] -> ([TargetId], [String])
forall a b. [(a, b)] -> ([a], [b])
unzip [(TargetId
i, [Char
' ' | String -> Bool
isUpper1 String
name] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
lower String
name) | (Just TargetId
i, Item
x) <- [(Maybe TargetId, Item)]
xs, String
name <- Item -> [String]
itemNamePart Item
x]
    let b :: ByteString
b = [String] -> ByteString
bstr0Join ([String] -> ByteString) -> [String] -> ByteString
forall a b. (a -> b) -> a -> b
$ [String]
strs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"",String
""]
    CInt
bound <- ByteString -> (Ptr CChar -> IO CInt) -> IO CInt
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
BS.unsafeUseAsCString ByteString
b ((Ptr CChar -> IO CInt) -> IO CInt)
-> (Ptr CChar -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
ptr -> Ptr CChar -> IO CInt
text_search_bound Ptr CChar
ptr
    StoreWrite -> NamesSize Int -> Int -> IO ()
forall (t :: * -> *) a.
(Typeable (t a), Typeable a, Stored a) =>
StoreWrite -> t a -> a -> IO ()
storeWrite StoreWrite
store NamesSize Int
NamesSize (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
bound
    StoreWrite
-> NamesItems (Vector TargetId) -> Vector TargetId -> IO ()
forall (t :: * -> *) a.
(Typeable (t a), Typeable a, Stored a) =>
StoreWrite -> t a -> a -> IO ()
storeWrite StoreWrite
store NamesItems (Vector TargetId)
NamesItems (Vector TargetId -> IO ()) -> Vector TargetId -> IO ()
forall a b. (a -> b) -> a -> b
$ [TargetId] -> Vector TargetId
forall a. Storable a => [a] -> Vector a
V.fromList [TargetId]
ids
    StoreWrite -> NamesText ByteString -> ByteString -> IO ()
forall (t :: * -> *) a.
(Typeable (t a), Typeable a, Stored a) =>
StoreWrite -> t a -> a -> IO ()
storeWrite StoreWrite
store NamesText ByteString
NamesText ByteString
b

itemNamePart :: Item -> [String]
itemNamePart :: Item -> [String]
itemNamePart (IModule ModName
x) = [[String] -> String
forall a. HasCallStack => [a] -> a
last ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> [String]
forall a. (HasCallStack, Eq a) => [a] -> [a] -> [[a]]
splitOn String
"." (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ ModName -> String
strUnpack ModName
x]
itemNamePart Item
x = Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList (Maybe String -> [String]) -> Maybe String -> [String]
forall a b. (a -> b) -> a -> b
$ ModName -> String
strUnpack (ModName -> String) -> Maybe ModName -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Item -> Maybe ModName
itemName Item
x

searchNames :: StoreRead -> Bool -> [String] -> [TargetId]
-- very important to not search for [" "] or [] since the output buffer is too small
searchNames :: StoreRead -> Bool -> [String] -> [TargetId]
searchNames StoreRead
store Bool
exact ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"") ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
trim -> [String]
xs) = IO [TargetId] -> [TargetId]
forall a. IO a -> a
unsafePerformIO (IO [TargetId] -> [TargetId]) -> IO [TargetId] -> [TargetId]
forall a b. (a -> b) -> a -> b
$ do
    let vs :: Vector TargetId
vs = StoreRead -> NamesItems (Vector TargetId) -> Vector TargetId
forall (t :: * -> *) a.
(Typeable (t a), Typeable a, Stored a) =>
StoreRead -> t a -> a
storeRead StoreRead
store NamesItems (Vector TargetId)
NamesItems
    -- if there are no questions, we will match everything, which exceeds the result buffer
    if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
xs then [TargetId] -> IO [TargetId]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TargetId] -> IO [TargetId]) -> [TargetId] -> IO [TargetId]
forall a b. (a -> b) -> a -> b
$ Vector TargetId -> [TargetId]
forall a. Storable a => Vector a -> [a]
V.toList Vector TargetId
vs else do
        let tweak :: String -> ByteString
tweak String
x = String -> ByteString
bstrPack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char
' ' | String -> Bool
isUpper1 String
x] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
lower String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\0"
        IO (Ptr CInt)
-> (Ptr CInt -> IO ())
-> (Ptr CInt -> IO [TargetId])
-> IO [TargetId]
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Int -> IO (Ptr CInt)
forall a. Storable a => Int -> IO (Ptr a)
mallocArray (Int -> IO (Ptr CInt)) -> Int -> IO (Ptr CInt)
forall a b. (a -> b) -> a -> b
$ StoreRead -> NamesSize Int -> Int
forall (t :: * -> *) a.
(Typeable (t a), Typeable a, Stored a) =>
StoreRead -> t a -> a
storeRead StoreRead
store NamesSize Int
NamesSize) Ptr CInt -> IO ()
forall a. Ptr a -> IO ()
free ((Ptr CInt -> IO [TargetId]) -> IO [TargetId])
-> (Ptr CInt -> IO [TargetId]) -> IO [TargetId]
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
result ->
            ByteString -> (Ptr CChar -> IO [TargetId]) -> IO [TargetId]
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
BS.unsafeUseAsCString (StoreRead -> NamesText ByteString -> ByteString
forall (t :: * -> *) a.
(Typeable (t a), Typeable a, Stored a) =>
StoreRead -> t a -> a
storeRead StoreRead
store NamesText ByteString
NamesText) ((Ptr CChar -> IO [TargetId]) -> IO [TargetId])
-> (Ptr CChar -> IO [TargetId]) -> IO [TargetId]
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
haystack ->
                [(Ptr CChar -> IO [TargetId]) -> IO [TargetId]]
-> ([Ptr CChar] -> IO [TargetId]) -> IO [TargetId]
forall a r. [(a -> r) -> r] -> ([a] -> r) -> r
withs ((String -> (Ptr CChar -> IO [TargetId]) -> IO [TargetId])
-> [String] -> [(Ptr CChar -> IO [TargetId]) -> IO [TargetId]]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> (Ptr CChar -> IO [TargetId]) -> IO [TargetId]
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
BS.unsafeUseAsCString (ByteString -> (Ptr CChar -> IO [TargetId]) -> IO [TargetId])
-> (String -> ByteString)
-> String
-> (Ptr CChar -> IO [TargetId])
-> IO [TargetId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
tweak) [String]
xs) (([Ptr CChar] -> IO [TargetId]) -> IO [TargetId])
-> ([Ptr CChar] -> IO [TargetId]) -> IO [TargetId]
forall a b. (a -> b) -> a -> b
$ \[Ptr CChar]
needles ->
                    Ptr CChar
-> [Ptr CChar]
-> (Ptr (Ptr CChar) -> IO [TargetId])
-> IO [TargetId]
forall a b. Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b
withArray0 Ptr CChar
forall a. Ptr a
nullPtr [Ptr CChar]
needles ((Ptr (Ptr CChar) -> IO [TargetId]) -> IO [TargetId])
-> (Ptr (Ptr CChar) -> IO [TargetId]) -> IO [TargetId]
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr CChar)
needles -> do
                        CInt
found <- Ptr CChar -> Ptr (Ptr CChar) -> CInt -> Ptr CInt -> IO CInt
c_text_search Ptr CChar
haystack Ptr (Ptr CChar)
needles (if Bool
exact then CInt
1 else CInt
0) Ptr CInt
result
                        [CInt]
xs <- Int -> Ptr CInt -> IO [CInt]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
found) Ptr CInt
result
                        [TargetId] -> IO [TargetId]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TargetId] -> IO [TargetId]) -> [TargetId] -> IO [TargetId]
forall a b. (a -> b) -> a -> b
$ (CInt -> TargetId) -> [CInt] -> [TargetId]
forall a b. (a -> b) -> [a] -> [b]
map ((Vector TargetId
vs Vector TargetId -> Int -> TargetId
forall a. Storable a => Vector a -> Int -> a
V.!) (Int -> TargetId) -> (CInt -> Int) -> CInt -> TargetId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) [CInt]
xs

{-# NOINLINE c_text_search #-} -- for profiling
c_text_search :: Ptr CChar -> Ptr (Ptr CChar) -> CInt -> Ptr CInt -> IO CInt
c_text_search Ptr CChar
a Ptr (Ptr CChar)
b CInt
c Ptr CInt
d = Ptr CChar -> Ptr (Ptr CChar) -> CInt -> Ptr CInt -> IO CInt
text_search Ptr CChar
a Ptr (Ptr CChar)
b CInt
c Ptr CInt
d