module Hoogle.DataBase.SubstrSearch
(SubstrSearch, createSubstrSearch
,searchSubstrSearch
,searchExactSearch
,completionsSubstrSearch
) where
import Hoogle.Store.All
import qualified Data.Set as Set
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.Char as C
import General.Base
import Data.Array
import Hoogle.Type.All
import Hoogle.Score.All
data SubstrSearch a = SubstrSearch
{text :: BString
,lens :: BString
,inds :: Array Int a
}
deriving Typeable
instance NFData a => NFData (SubstrSearch a) where
rnf (SubstrSearch a b c) = rnf (a `seq` (),b `seq` (),c)
createSubstrSearch :: [(String,a)] -> SubstrSearch a
createSubstrSearch xs = SubstrSearch
(fromString $ concat ts2)
(BS.pack $ map fromIntegral ls2)
(listArray (0,length is1) is)
where
(ts,is) = unzip xs
(ts2,ls2) = f "" ts
f x (y:ys) = first (y:) $ second (length y:) $ f y ys
f x [] = ([],[])
data S a = S
{sCount :: !Int
,sFocus :: !BS.ByteString
,sPrefix :: ![(a,EntryView,Score)]
,sInfix :: ![(a,EntryView,Score)]
}
toChar :: Word8 -> Char
toChar = C.chr . fromIntegral
ascii :: Char -> Word8
ascii = fromIntegral . C.ord
searchSubstrSearch :: SubstrSearch a -> String -> [(a, EntryView, Score)]
searchSubstrSearch x y = reverse (sPrefix sN) ++ reverse (sInfix sN)
where
view = FocusOn y
match = bsMatch (BSC.pack y)
sN = BS.foldl f s0 $ lens x
s0 = S 0 (text x) [] []
f s ii = addCount $ moveFocus i $ maybe id addMatch t s
where t = match i $ BS.map (ascii . toChar)
$ BS.unsafeTake i $ sFocus s
i = fromIntegral ii
addCount s = s{sCount=sCount s+1}
moveFocus i s = s{sFocus=BS.unsafeDrop i $ sFocus s}
addMatch MatchSubstr s = s{sInfix =(inds x ! sCount s,view,textScore MatchSubstr):sInfix s}
addMatch t s = s{sPrefix=(inds x ! sCount s,view,textScore t):sPrefix s}
searchExactSearch :: SubstrSearch a -> String -> [(a, EntryView, Score)]
searchExactSearch x y = reverse (sPrefix sN)
where
view = FocusOn y
match = bsMatch (BSC.pack y)
sN = BS.foldl f s0 $ lens x
s0 = S 0 (text x) [] []
f s ii = addCount $ moveFocus i $ maybe id addMatch t s
where t = match i $ BS.unsafeTake i $ sFocus s
i = fromIntegral ii
addCount s = s{sCount=sCount s+1}
moveFocus i s = s{sFocus=BS.unsafeDrop i $ sFocus s}
addMatch MatchExact s = s{sPrefix=(inds x ! sCount s,view,textScore MatchExact):sPrefix s}
addMatch _ s = s
data S2 = S2
{_s2Focus :: !BS.ByteString
,s2Result :: Set.Set BS.ByteString
}
completionsSubstrSearch :: SubstrSearch a -> String -> [String]
completionsSubstrSearch x y = map (\x -> y ++ drop ny (BSC.unpack x)) $ take 10 $ Set.toAscList $
s2Result $ BS.foldl f (S2 (text x) Set.empty) $ lens x
where
ny = length y
ly = fromString $ map toLower y
f (S2 foc res) ii = S2 (BS.unsafeDrop i foc) (if ly `BS.isPrefixOf` x then Set.insert x res else res)
where x = BS.map (ascii . toLower . toChar) $ BS.unsafeTake i foc
i = fromIntegral ii
instance Show a => Show (SubstrSearch a) where
show x = "SubstrSearch"
instance (Typeable a, Store a) => Store (SubstrSearch a) where
put (SubstrSearch a b c) = putDefer $ put3 a b c
get = getDefer $ get3 SubstrSearch
bsMatch :: BS.ByteString -> Int -> BS.ByteString -> Maybe TextMatch
bsMatch x
| nx == 0 = \ny _ -> Just $ if ny == 0 then MatchExact else MatchPrefix
| nx == 1 = \ny y ->
maybe (bsCharMatch MatchExactCI MatchPrefixCI False
(BS.head (bsLower x)) ny (bsLower y))
Just (bsCharMatch MatchExact MatchPrefix True
(BS.head x) ny y)
| otherwise = \ny y ->
maybe (bsWordMatch MatchExactCI MatchPrefixCI False
(bsLower x) ny (bsLower y))
Just (bsWordMatch MatchExact MatchPrefix True x ny y)
where
nx = BS.length x
bsLower = BS.map (ascii . toLower . toChar)
bsCharMatch exactKind prefixKind ignoreSubstr c ny y =
case BS.elemIndex c y of
Nothing -> Nothing
Just 0 -> Just $ if ny == 1
then exactKind
else prefixKind
Just _
| ignoreSubstr -> Nothing
| otherwise -> Just MatchSubstr
bsWordMatch exactKind prefixKind ignoreSubstr x' ny y =
if BS.isPrefixOf x' y
then Just (if nx == ny then exactKind else prefixKind)
else if not ignoreSubstr && BS.isInfixOf x' y
then Just MatchSubstr
else Nothing