{-# 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, [[Char]]
strs) = [(TargetId, [Char])] -> ([TargetId], [[Char]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(TargetId
i, [Char
' ' | [Char] -> Bool
isUpper1 [Char]
name] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
lower [Char]
name) | (Just TargetId
i, Item
x) <- [(Maybe TargetId, Item)]
xs, [Char]
name <- Item -> [[Char]]
itemNamePart Item
x]
    let b :: BStr0
b = [[Char]] -> BStr0
bstr0Join ([[Char]] -> BStr0) -> [[Char]] -> BStr0
forall a b. (a -> b) -> a -> b
$ [[Char]]
strs [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"",[Char]
""]
    CInt
bound <- BStr0 -> (CString -> IO CInt) -> IO CInt
forall a. BStr0 -> (CString -> IO a) -> IO a
BS.unsafeUseAsCString BStr0
b ((CString -> IO CInt) -> IO CInt)
-> (CString -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \CString
ptr -> CString -> IO CInt
text_search_bound CString
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 BStr0 -> BStr0 -> IO ()
forall (t :: * -> *) a.
(Typeable (t a), Typeable a, Stored a) =>
StoreWrite -> t a -> a -> IO ()
storeWrite StoreWrite
store NamesText BStr0
NamesText BStr0
b

itemNamePart :: Item -> [String]
itemNamePart :: Item -> [[Char]]
itemNamePart (IModule ModName
x) = [[[Char]] -> [Char]
forall a. [a] -> a
last ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [[Char]]
forall a. (Partial, Eq a) => [a] -> [a] -> [[a]]
splitOn [Char]
"." ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ModName -> [Char]
strUnpack ModName
x]
itemNamePart Item
x = Maybe [Char] -> [[Char]]
forall a. Maybe a -> [a]
maybeToList (Maybe [Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ModName -> [Char]
strUnpack (ModName -> [Char]) -> Maybe ModName -> Maybe [Char]
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 -> [[Char]] -> [TargetId]
searchNames StoreRead
store Bool
exact (([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
"") ([[Char]] -> [[Char]])
-> ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
trim -> [[Char]]
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 [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
xs then [TargetId] -> IO [TargetId]
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 :: [Char] -> BStr0
tweak [Char]
x = [Char] -> BStr0
bstrPack ([Char] -> BStr0) -> [Char] -> BStr0
forall a b. (a -> b) -> a -> b
$ [Char
' ' | [Char] -> Bool
isUpper1 [Char]
x] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
lower [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\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 ->
            BStr0 -> (CString -> IO [TargetId]) -> IO [TargetId]
forall a. BStr0 -> (CString -> IO a) -> IO a
BS.unsafeUseAsCString (StoreRead -> NamesText BStr0 -> BStr0
forall (t :: * -> *) a.
(Typeable (t a), Typeable a, Stored a) =>
StoreRead -> t a -> a
storeRead StoreRead
store NamesText BStr0
NamesText) ((CString -> IO [TargetId]) -> IO [TargetId])
-> (CString -> IO [TargetId]) -> IO [TargetId]
forall a b. (a -> b) -> a -> b
$ \CString
haystack ->
                [(CString -> IO [TargetId]) -> IO [TargetId]]
-> ([CString] -> IO [TargetId]) -> IO [TargetId]
forall a r. [(a -> r) -> r] -> ([a] -> r) -> r
withs (([Char] -> (CString -> IO [TargetId]) -> IO [TargetId])
-> [[Char]] -> [(CString -> IO [TargetId]) -> IO [TargetId]]
forall a b. (a -> b) -> [a] -> [b]
map (BStr0 -> (CString -> IO [TargetId]) -> IO [TargetId]
forall a. BStr0 -> (CString -> IO a) -> IO a
BS.unsafeUseAsCString (BStr0 -> (CString -> IO [TargetId]) -> IO [TargetId])
-> ([Char] -> BStr0)
-> [Char]
-> (CString -> IO [TargetId])
-> IO [TargetId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> BStr0
tweak) [[Char]]
xs) (([CString] -> IO [TargetId]) -> IO [TargetId])
-> ([CString] -> IO [TargetId]) -> IO [TargetId]
forall a b. (a -> b) -> a -> b
$ \[CString]
needles ->
                    CString
-> [CString] -> (Ptr CString -> IO [TargetId]) -> IO [TargetId]
forall a b. Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b
withArray0 CString
forall a. Ptr a
nullPtr [CString]
needles ((Ptr CString -> IO [TargetId]) -> IO [TargetId])
-> (Ptr CString -> IO [TargetId]) -> IO [TargetId]
forall a b. (a -> b) -> a -> b
$ \Ptr CString
needles -> do
                        CInt
found <- CString -> Ptr CString -> CInt -> Ptr CInt -> IO CInt
c_text_search CString
haystack Ptr CString
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 (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 :: CString -> Ptr CString -> CInt -> Ptr CInt -> IO CInt
c_text_search CString
a Ptr CString
b CInt
c Ptr CInt
d = CString -> Ptr CString -> CInt -> Ptr CInt -> IO CInt
text_search CString
a Ptr CString
b CInt
c Ptr CInt
d