{-# LANGUAGE DeriveDataTypeable, FlexibleInstances,
UndecidableInstances, MultiParamTypeClasses #-}
module Data.TCache.IndexText(
indexText
, indexList
, contains
, containsElem
, allElemsOf) where
import Data.TCache
import Data.TCache.IndexQuery
import Data.TCache.Defs
import qualified Data.Text.Lazy as T
import Data.Typeable
import qualified Data.Map as M
import Data.Maybe
import Data.Bits
import System.Mem.StableName
import Data.List((\\))
import GHC.Conc(unsafeIOToSTM)
import Data.Char
import Data.ByteString.Lazy.Char8(pack, unpack)
import Control.Monad
data IndexText = IndexText
!String
Int
(M.Map String Int)
(M.Map Int String)
(M.Map T.Text Integer)
deriving (Typeable)
instance Show IndexText where
show :: IndexText -> String
show (IndexText String
t Int
a Map String Int
b Map Int String
c Map Text Integer
d)= forall a. Show a => a -> String
show (String
t,Int
a,Map String Int
b,Map Int String
c,Map Text Integer
d)
instance Read IndexText where
readsPrec :: Int -> ReadS IndexText
readsPrec Int
n String
str= [(String
-> Int
-> Map String Int
-> Map Int String
-> Map Text Integer
-> IndexText
IndexText String
t Int
a Map String Int
b Map Int String
c Map Text Integer
d, String
str2)| ((String
t,Int
a,Map String Int
b,Map Int String
c,Map Text Integer
d),String
str2) <- forall a. Read a => Int -> ReadS a
readsPrec Int
n String
str]
instance Serializable IndexText where
serialize :: IndexText -> ByteString
serialize= String -> ByteString
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
deserialize :: ByteString -> IndexText
deserialize= forall a. Read a => String -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
unpack
setPersist :: IndexText -> Maybe Persist
setPersist= forall a b. a -> b -> a
const forall a. Maybe a
Nothing
instance Indexable IndexText where
key :: IndexText -> String
key (IndexText String
v Int
_ Map String Int
_ Map Int String
_ Map Text Integer
_)= String
"indextext-" forall a. [a] -> [a] -> [a]
++ String
v
instance IResource IndexText where
keyResource :: IndexText -> String
keyResource = forall a. Indexable a => a -> String
key
writeResource :: IndexText -> IO ()
writeResource =forall a. (Indexable a, Serializable a, Typeable a) => a -> IO ()
defWriteResource
readResourceByKey :: String -> IO (Maybe IndexText)
readResourceByKey = forall a.
(Indexable a, Serializable a, Typeable a) =>
String -> IO (Maybe a)
defReadResourceByKey
delResource :: IndexText -> IO ()
delResource = forall a. (Indexable a, Serializable a, Typeable a) => a -> IO ()
defDelResource
add :: DBRef IndexText -> String -> String -> [T.Text] -> STM ()
add :: DBRef IndexText -> String -> String -> [Text] -> STM ()
add DBRef IndexText
ref String
t String
key1 [Text]
w = DBRef IndexText
-> String
-> (Integer -> Int -> Integer)
-> [Text]
-> String
-> STM ()
op DBRef IndexText
ref String
t forall a. Bits a => a -> Int -> a
setBit [Text]
w String
key1
del :: DBRef IndexText -> String -> String -> [T.Text] -> STM ()
del :: DBRef IndexText -> String -> String -> [Text] -> STM ()
del DBRef IndexText
ref String
t String
key1 [Text]
w = DBRef IndexText
-> String
-> (Integer -> Int -> Integer)
-> [Text]
-> String
-> STM ()
op DBRef IndexText
ref String
t forall a. Bits a => a -> Int -> a
clearBit [Text]
w String
key1
op :: DBRef IndexText -> String -> (Integer -> Int -> Integer) -> [T.Text] -> String -> STM ()
op :: DBRef IndexText
-> String
-> (Integer -> Int -> Integer)
-> [Text]
-> String
-> STM ()
op DBRef IndexText
refIndex String
t Integer -> Int -> Integer
set [Text]
ws1 String
key1 = do
Maybe IndexText
mindex <- forall a. (IResource a, Typeable a) => DBRef a -> STM (Maybe a)
readDBRef DBRef IndexText
refIndex
let mindex' :: Maybe IndexText
mindex'= Maybe IndexText -> [Text] -> Maybe IndexText
process Maybe IndexText
mindex [Text]
ws1
forall a. (IResource a, Typeable a) => DBRef a -> a -> STM ()
writeDBRef DBRef IndexText
refIndex forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust Maybe IndexText
mindex'
where
process :: Maybe IndexText -> [Text] -> Maybe IndexText
process Maybe IndexText
mindex []= Maybe IndexText
mindex
process Maybe IndexText
mindex (Text
w:[Text]
ws) =
case Maybe IndexText
mindex of
Maybe IndexText
Nothing -> Maybe IndexText -> [Text] -> Maybe IndexText
process (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
-> Int
-> Map String Int
-> Map Int String
-> Map Text Integer
-> IndexText
IndexText String
t Int
0 (forall k a. k -> a -> Map k a
M.singleton String
key1 Int
0) (forall k a. k -> a -> Map k a
M.singleton Int
0 String
key1) (forall k a. k -> a -> Map k a
M.singleton Text
w Integer
1)) [Text]
ws
Just (IndexText String
_ Int
n Map String Int
mapSI Map Int String
mapIS Map Text Integer
map1) -> do
let (Int
docLocation, Int
n1, Map String Int
mapSI',Map Int String
mapIS')= case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
key1 Map String Int
mapSI of
Maybe Int
Nothing -> let n2 :: Int
n2= Int
nforall a. Num a => a -> a -> a
+Int
1 in (Int
n2, Int
n2
, forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
key1 Int
n2 Map String Int
mapSI
, forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
n2 String
key1 Map Int String
mapIS)
Just Int
m -> (Int
m,Int
n, Map String Int
mapSI,Map Int String
mapIS)
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
w Map Text Integer
map1 of
Maybe Integer
Nothing ->
Maybe IndexText -> [Text] -> Maybe IndexText
process (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
-> Int
-> Map String Int
-> Map Int String
-> Map Text Integer
-> IndexText
IndexText String
t Int
n1 Map String Int
mapSI' Map Int String
mapIS' (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
w (Integer -> Int -> Integer
set Integer
0 Int
docLocation) Map Text Integer
map1)) [Text]
ws
Just Integer
integer ->
Maybe IndexText -> [Text] -> Maybe IndexText
process (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
-> Int
-> Map String Int
-> Map Int String
-> Map Text Integer
-> IndexText
IndexText String
t Int
n1 Map String Int
mapSI' Map Int String
mapIS' forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
w (Integer -> Int -> Integer
set Integer
integer Int
docLocation) Map Text Integer
map1) [Text]
ws
addProto :: Typeable a => a -> IO ()
addProto :: forall a. Typeable a => a -> IO ()
addProto a
sel = do
let [TypeRep
t1,TypeRep
t2]= TypeRep -> [TypeRep]
typeRepArgs forall a b. (a -> b) -> a -> b
$! forall a. Typeable a => a -> TypeRep
typeOf a
sel
let t :: String
t = forall a. Show a => a -> String
show TypeRep
t1 forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TypeRep
t2
let proto :: IndexText
proto = String
-> Int
-> Map String Int
-> Map Int String
-> Map Text Integer
-> IndexText
IndexText String
t Int
0 forall k a. Map k a
M.empty forall k a. Map k a
M.empty forall k a. Map k a
M.empty
forall a.
(IResource a, Typeable a) =>
[a] -> ([Maybe a] -> [a]) -> IO ()
withResources [IndexText
proto] forall a b. (a -> b) -> a -> b
$ forall {a} {a}. a -> [Maybe a] -> [a]
init' IndexText
proto
where
init' :: a -> [Maybe a] -> [a]
init' a
proto [Maybe a
Nothing] = [a
proto]
init' a
_ [Just a
_] = []
init' a
_ [] = forall a. HasCallStack => String -> a
error String
"this will never happen(?)"
init' a
_ (Maybe a
Nothing:Maybe a
_:[Maybe a]
_) = forall a. HasCallStack => String -> a
error String
"this will never happen(?)"
init' a
_ (Just a
_:Maybe a
_:[Maybe a]
_) = forall a. HasCallStack => String -> a
error String
"this will never happen(?)"
indexText
:: (IResource a, Typeable a, Typeable b)
=> (a -> b)
-> (b -> T.Text)
-> IO ()
indexText :: forall a b.
(IResource a, Typeable a, Typeable b) =>
(a -> b) -> (b -> Text) -> IO ()
indexText a -> b
sel b -> Text
convert= do
forall a.
(IResource a, Typeable a) =>
(DBRef a -> Maybe a -> STM ()) -> IO ()
addTrigger (forall a b.
(IResource a, Typeable a, Typeable b) =>
(a -> b) -> (b -> [Text]) -> DBRef a -> Maybe a -> STM ()
indext a -> b
sel (Text -> [Text]
words1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Text
convert))
forall a. Typeable a => a -> IO ()
addProto a -> b
sel
indexList
:: (IResource a, Typeable a, Typeable b)
=> (a -> b)
-> (b -> [T.Text])
-> IO ()
indexList :: forall a b.
(IResource a, Typeable a, Typeable b) =>
(a -> b) -> (b -> [Text]) -> IO ()
indexList a -> b
sel b -> [Text]
convert= do
forall a.
(IResource a, Typeable a) =>
(DBRef a -> Maybe a -> STM ()) -> IO ()
addTrigger (forall a b.
(IResource a, Typeable a, Typeable b) =>
(a -> b) -> (b -> [Text]) -> DBRef a -> Maybe a -> STM ()
indext a -> b
sel b -> [Text]
convert)
forall a. Typeable a => a -> IO ()
addProto a -> b
sel
indext :: (IResource a, Typeable a,Typeable b)
=> (a -> b) -> (b -> [T.Text]) -> DBRef a -> Maybe a -> STM()
indext :: forall a b.
(IResource a, Typeable a, Typeable b) =>
(a -> b) -> (b -> [Text]) -> DBRef a -> Maybe a -> STM ()
indext a -> b
sel b -> [Text]
convert DBRef a
dbref Maybe a
mreg = STM ()
f1
where
f1 :: STM ()
f1 = do
Maybe a
moldreg <- forall a. (IResource a, Typeable a) => DBRef a -> STM (Maybe a)
readDBRef DBRef a
dbref
case (Maybe a
moldreg, Maybe a
mreg) of
(Maybe a
Nothing, Just a
reg) -> DBRef IndexText -> String -> String -> [Text] -> STM ()
add DBRef IndexText
refIndex String
t (forall a. IResource a => a -> String
keyResource a
reg) forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> [Text]
convert forall a b. (a -> b) -> a -> b
$ a -> b
sel a
reg
(Just a
oldreg, Maybe a
Nothing) -> DBRef IndexText -> String -> String -> [Text] -> STM ()
del DBRef IndexText
refIndex String
t (forall a. IResource a => a -> String
keyResource a
oldreg) forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> [Text]
convert forall a b. (a -> b) -> a -> b
$ a -> b
sel a
oldreg
(Just a
oldreg, Just a
reg) -> do
StableName b
st <- forall a. IO a -> STM a
unsafeIOToSTM forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (StableName a)
makeStableName forall a b. (a -> b) -> a -> b
$ a -> b
sel a
oldreg
StableName b
st' <- forall a. IO a -> STM a
unsafeIOToSTM forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (StableName a)
makeStableName forall a b. (a -> b) -> a -> b
$ a -> b
sel a
reg
if StableName b
st forall a. Eq a => a -> a -> Bool
== StableName b
st'
then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do
let key1 :: String
key1 = forall a. IResource a => a -> String
keyResource a
reg
let wrds :: [Text]
wrds = b -> [Text]
convert forall a b. (a -> b) -> a -> b
$ a -> b
sel a
oldreg
let wrds' :: [Text]
wrds' = b -> [Text]
convert forall a b. (a -> b) -> a -> b
$ a -> b
sel a
reg
let new :: [Text]
new = [Text]
wrds' forall a. Eq a => [a] -> [a] -> [a]
\\ [Text]
wrds
let old :: [Text]
old = [Text]
wrds forall a. Eq a => [a] -> [a] -> [a]
\\ [Text]
wrds'
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
old) forall a b. (a -> b) -> a -> b
$ DBRef IndexText -> String -> String -> [Text] -> STM ()
del DBRef IndexText
refIndex String
t String
key1 [Text]
old
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
new) forall a b. (a -> b) -> a -> b
$ DBRef IndexText -> String -> String -> [Text] -> STM ()
add DBRef IndexText
refIndex String
t String
key1 [Text]
new
(Maybe a
Nothing, Maybe a
Nothing) -> forall a. HasCallStack => String -> a
error String
"this will never happen(?)"
where
[TypeRep
t1, TypeRep
t2] = TypeRep -> [TypeRep]
typeRepArgs forall a b. (a -> b) -> a -> b
$! forall a. Typeable a => a -> TypeRep
typeOf a -> b
sel
t :: String
t = forall a. Show a => a -> String
show TypeRep
t1 forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TypeRep
t2
refIndex :: DBRef IndexText
refIndex = forall a. (Typeable a, IResource a) => String -> DBRef a
getDBRef forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Indexable a => a -> String
key forall a b. (a -> b) -> a -> b
$ String
-> Int
-> Map String Int
-> Map Int String
-> Map Text Integer
-> IndexText
IndexText String
t forall {a}. a
u forall {a}. a
u forall {a}. a
u forall {a}. a
u
where
u :: a
u = forall a. HasCallStack => a
undefined
targs :: Typeable a => a -> STM (Maybe IndexText)
targs :: forall a. Typeable a => a -> STM (Maybe IndexText)
targs a
sel = do
let [TypeRep
t1, TypeRep
t2]= TypeRep -> [TypeRep]
typeRepArgs forall a b. (a -> b) -> a -> b
$! forall a. Typeable a => a -> TypeRep
typeOf a
sel
let t :: String
t= forall a. Show a => a -> String
show TypeRep
t1 forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TypeRep
t2
let u :: a
u= forall a. HasCallStack => a
undefined
forall a x.
(IResource a, Typeable a) =>
[a] -> ([Maybe a] -> Resources a x) -> STM x
withSTMResources [String
-> Int
-> Map String Int
-> Map Int String
-> Map Text Integer
-> IndexText
IndexText String
t forall {a}. a
u forall {a}. a
u forall {a}. a
u forall {a}. a
u]
forall a b. (a -> b) -> a -> b
$ \[Maybe IndexText
r] -> forall a. Resources a ()
resources{toReturn :: Maybe IndexText
toReturn= Maybe IndexText
r}
containsElem :: (IResource a, Typeable a, Typeable b) => (a -> b) -> String -> STM [DBRef a]
containsElem :: forall a b.
(IResource a, Typeable a, Typeable b) =>
(a -> b) -> String -> STM [DBRef a]
containsElem a -> b
sel String
wstr = do
let w :: Text
w = String -> Text
T.pack String
wstr
Maybe IndexText
mr <- forall a. Typeable a => a -> STM (Maybe IndexText)
targs a -> b
sel
case Maybe IndexText
mr of
Maybe IndexText
Nothing -> do
let fields :: String
fields = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall a. Typeable a => a -> TypeRep
typeOf a -> b
sel
forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
String
"the index for " forall a. [a] -> [a] -> [a]
++
String
fields forall a. [a] -> [a] -> [a]
++ String
" do not exist. At main, use \"Data.TCache.IndexQuery.index\" to start indexing this field"
Just (IndexText String
_ Int
n Map String Int
_ Map Int String
mmapIntString Map Text Integer
map1) ->
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
w Map Text Integer
map1 of
Maybe Integer
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
Just Integer
integer -> do
let mns :: [Maybe Int]
mns =
forall a b. (a -> b) -> [a] -> [b]
map
(\Int
i ->
if forall a. Bits a => a -> Int -> Bool
testBit Integer
integer Int
i
then forall a. a -> Maybe a
Just Int
i
else forall a. Maybe a
Nothing)
[Int
0 .. Int
n]
let wordsr :: [String]
wordsr = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map Int String
mmapIntString) forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe Int]
mns
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. (Typeable a, IResource a) => String -> DBRef a
getDBRef [String]
wordsr
allElemsOf :: (IResource a, Typeable a, Typeable b) => (a -> b) -> STM [T.Text]
allElemsOf :: forall a b.
(IResource a, Typeable a, Typeable b) =>
(a -> b) -> STM [Text]
allElemsOf a -> b
sel = do
Maybe IndexText
mr <- forall a. Typeable a => a -> STM (Maybe IndexText)
targs a -> b
sel
case Maybe IndexText
mr of
Maybe IndexText
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
Just (IndexText String
_ Int
_ Map String Int
_ Map Int String
_ Map Text Integer
map') -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
M.keys Map Text Integer
map'
words1 :: T.Text -> [T.Text]
words1 :: Text -> [Text]
words1 = forall a. (a -> Bool) -> [a] -> [a]
filter Text -> Bool
filterWordt forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
T.split (\Char
c -> Char -> Bool
isSeparator Char
c Bool -> Bool -> Bool
|| Char
cforall a. Eq a => a -> a -> Bool
==Char
'\n' Bool -> Bool -> Bool
|| Char -> Bool
isPunctuation Char
c )
contains
:: (IResource a, Typeable a, Typeable b)
=>( a -> b)
-> String
-> STM [DBRef a]
contains :: forall a b.
(IResource a, Typeable a, Typeable b) =>
(a -> b) -> String -> STM [DBRef a]
contains a -> b
sel String
str= case String -> [String]
words String
str of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return []
[String
w] -> forall a b.
(IResource a, Typeable a, Typeable b) =>
(a -> b) -> String -> STM [DBRef a]
containsElem a -> b
sel String
w
[String]
ws -> do
let rs :: [STM [DBRef a]]
rs = forall a b. (a -> b) -> [a] -> [b]
map (forall a b.
(IResource a, Typeable a, Typeable b) =>
(a -> b) -> String -> STM [DBRef a]
containsElem a -> b
sel) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter forall (t :: * -> *). Foldable t => t Char -> Bool
filterWord [String]
ws
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 forall set set' setResult.
SetOperations set set' setResult =>
STM set -> STM set' -> STM setResult
(.&&.) [STM [DBRef a]]
rs
filterWordt :: T.Text -> Bool
filterWordt :: Text -> Bool
filterWordt Text
w = Text -> Int64
T.length Text
w forall a. Ord a => a -> a -> Bool
>Int64
2 Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Char
c -> Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c) (Text -> String
T.unpack Text
w)
filterWord :: Foldable t => t Char -> Bool
filterWord :: forall (t :: * -> *). Foldable t => t Char -> Bool
filterWord t Char
w = forall (t :: * -> *) a. Foldable t => t a -> Int
length t Char
w forall a. Ord a => a -> a -> Bool
>Int
2 Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Char
c -> Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c) t Char
w