packages feed

hunt-searchengine (empty) → 0.3.0.0

raw patch · 57 files changed

+11303/−0 lines, 57 filesdep +HUnitdep +QuickCheckdep +aesonsetup-changed

Dependencies added: HUnit, QuickCheck, aeson, aeson-pretty, base, binary, bytestring, containers, data-default, data-r-tree, data-stringmap, deepseq, directory, dlist, filepath, ghc-heap-view, hslogger, hunt-searchengine, hxt-regex-xmlschema, monad-parallel, mtl, murmur-hash, old-locale, parsec, random, test-framework, test-framework-hunit, test-framework-quickcheck2, text, time, transformers, unordered-containers, vector

Files

+ LICENSE view
@@ -0,0 +1,22 @@+The MIT License (MIT)++Copyright (c) 2007 Timo B. Hübel, Sebastian M. Schlatt,+              2014 Chris Reumann, Ulf Sauer++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ Setup.lhs view
@@ -0,0 +1,8 @@+#!/usr/bin/runhaskell++> module Main where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ hunt-searchengine.cabal view
@@ -0,0 +1,189 @@+name:          hunt-searchengine+version:       0.3.0.0+license:       MIT+license-file:  LICENSE+author:        Chris Reumann, Ulf Sauer, Uwe Schmidt+copyright:     Chris Reumann, Ulf Sauer, Uwe Schmidt+maintainer:    Chris Reumann, Ulf Sauer, Uwe Schmidt+stability:     experimental+category:      Text, Data+synopsis:      A search and indexing engine.+homepage:      http://github.com/hunt-framework/+description:   The Hunt-Searchengine library provides a toolkit to+               create fast and flexible searchengines.+cabal-version: >=1.8+build-type:    Simple+-- tested-with:   ghc-7.6.3++-- extra-source-files:+--     README++-- enable with cabal test -ftest-strict+flag test-strict+  default:      False+  manual:       True++source-repository head+  type:        git+  location:    https://github.com/hunt-framework/hunt-searchengine.git++library++  build-depends: base                   >= 4.5  && < 5+               , aeson                  >= 0.6+               , aeson-pretty           >= 0.7+               , binary                 >= 0.5  && < 1+               , bytestring             < 1+               , containers             >= 0.5+               , data-r-tree            >= 0.0.5.0+               , data-stringmap         >= 1.0.1.1 && < 2+               , data-default+               , deepseq                >= 1.2+               , dlist+               , filepath               >= 1+               , hslogger               >= 1    && < 2+               , hxt-regex-xmlschema    >= 9.1+               , monad-parallel         >= 0.7+               , mtl                    >= 1.1  && < 3+               , murmur-hash+               , parsec                 >= 2.1  && < 4+               , text                   >= 1    && < 1.2+               , time                   >= 1.4  && < 2+               , transformers           >= 0.3+               , unordered-containers   >= 0.2+               , vector                 >= 0.10++  exposed-modules:+    Control.Concurrent.XMVar++    Data.Bijection+    Data.Bijection.Instances+    Data.IntMap.BinTree.Strict+    Data.IntSet.Cache+    Data.LimitedPriorityQueue+    Data.Text.Binary+    Data.Typeable.Binary++    GHC.Fingerprint.Binary+    GHC.Stats.Json++    Hunt.ClientInterface++    Hunt.Common+    Hunt.Common.ApiDocument+    Hunt.Common.BasicTypes+    Hunt.Common.DocDesc+    Hunt.Common.DocId+    Hunt.Common.DocIdMap+    Hunt.Common.DocIdSet+    Hunt.Common.Document+    Hunt.Common.Occurrences+    Hunt.Common.Positions+    Hunt.Common.RawResult+    Hunt.Common.IntermediateValue++    Hunt.Index.Schema+    Hunt.Index.Schema.Analyze+    Hunt.Index.Schema.Normalize.Date+    Hunt.Index.Schema.Normalize.Position+    Hunt.Index.Schema.Normalize.Int++    Hunt.Index+    Hunt.Index.IndexImpl+    Hunt.Index.PrefixTreeIndex+    Hunt.Index.PrefixTreeIndex2Dim+    Hunt.Index.RTreeIndex+    Hunt.Index.InvertedIndex++    Hunt.Index.Proxy.KeyIndex++    Hunt.DocTable+    Hunt.DocTable.HashedDocTable++    Hunt.ContextIndex++    Hunt.Interpreter+    Hunt.Interpreter.BasicCommand+    Hunt.Interpreter.Command++    Hunt.Query.Fuzzy+    Hunt.Query.Intermediate+    Hunt.Query.Language.Grammar+    Hunt.Query.Language.Parser+    Hunt.Query.Language.Builder+    Hunt.Query.Processor+    Hunt.Query.Ranking+    Hunt.Query.Result++    Hunt.Utility+    Hunt.Utility.Log+    Hunt.Utility.Output++  hs-source-dirs: src++  ghc-options: -Wall -funbox-strict-fields -fwarn-tabs -threaded++  extensions: MultiParamTypeClasses+              FlexibleContexts+              OverloadedStrings+              TypeFamilies+              ConstraintKinds+              KindSignatures+              CPP++test-suite Hunt-Tests+  hs-source-dirs:       test+  main-is:              Hunt.hs+  type:                 exitcode-stdio-1.0+  ghc-options:          -Wall+  extensions:           OverloadedStrings++  build-depends: base+               , containers+               , HUnit+               , QuickCheck+               , test-framework+               , test-framework-hunit+               , test-framework-quickcheck2+               , text+               , old-locale+               , time+               , aeson+               , binary+               , hunt-searchengine+               , mtl+               , random+               , directory+               , data-default+               , data-r-tree+               , monad-parallel++test-suite Hunt-Strictness+   hs-source-dirs:       test+   main-is:              Strictness.hs+   type:                 exitcode-stdio-1.0+   ghc-options:          -Wall+   extensions:           OverloadedStrings++   if !flag(test-strict)+     buildable: False+   else+     build-depends: base+                  , containers+                  , deepseq+                  , ghc-heap-view                >= 0.5+                  , HUnit+                  , hunt-searchengine+                  , mtl+                  , QuickCheck+                  , random                       >= 1.0+                  , test-framework+                  , test-framework-hunit+                  , test-framework-quickcheck2+                  , text+                  , aeson+                  , unordered-containers+                  , time+                  , old-locale+                  , monad-parallel+                  , data-default
+ src/Control/Concurrent/XMVar.hs view
@@ -0,0 +1,94 @@+-- ----------------------------------------------------------------------------+{- |+  An 'MVar' variation that only blocks for modification.+  Readers are never blocked but write access is carried out in sequence.++  This is done with two 'MVar's.+  While modification is done, the readers use the old value.+  When the modification is done, the old (unmodified) value is replaced with the new one.+  For this to work, the writers have to block each other which is done with the second 'MVar'.+  This process is encapsulated in 'modifyXMVar' and 'modifyXMVar_'.++  /Note/: This may increase the memory usage since there may be two value present at a time.+          This is intended to be used with (big) data structures where small changes are made.+-}+-- ----------------------------------------------------------------------------++module Control.Concurrent.XMVar+  ( XMVar+  , newXMVar+  , readXMVar, modifyXMVar, modifyXMVar_+  , takeXMVarWrite, putXMVarWrite+  , takeXMVarLock, putXMVarLock+  )+where++import           Control.Concurrent.MVar+import           Control.Exception++-- ------------------------------------------------------------++-- | An 'MVar' variation that only blocks for modification.+--   It consists of two 'MVar's. One for the value which can always be read and the second one+--   to block writers so that modifications are done sequentially.+data XMVar a = XMVar (MVar a) (MVar ())++-- ------------------------------------------------------------++-- | Create a new 'XMVar' with the supplied value.+newXMVar :: a -> IO (XMVar a)+newXMVar v = do+  m <- newMVar v+  l <- newMVar ()+  return $ XMVar m l++-- | Read the value.+readXMVar :: XMVar a -> IO a+readXMVar (XMVar m _)+  = readMVar m++-- | Modify the content.+modifyXMVar :: XMVar a -> (a -> IO (a, b)) -> IO b+modifyXMVar (XMVar m l) f+  = mask $ \restore -> do+    _ <- takeMVar l+    v <- readMVar m+    (v',a) <- restore (f v) `onException` putMVar l ()+    _ <- swapMVar m v'+    putMVar l ()+    return a++-- | Like 'modifyXMVar' but without a return value.+modifyXMVar_ :: XMVar a -> (a -> IO a) -> IO ()+modifyXMVar_ (XMVar m l) f+  = mask $ \restore -> do+    _  <- takeMVar l+    v  <- readMVar m+    v' <- restore (f v) `onException` putMVar l ()+    _  <- swapMVar m v'+    putMVar l ()++-- | Locks for writes and reads the value. Readers do not block each other.+--   'modifyXMVar' encapsulates 'takeXMVarWrite' and 'putXMVarWrite' and also handles exceptions.+takeXMVarWrite :: XMVar a -> IO a+takeXMVarWrite (XMVar m l)+  = takeMVar l >> readMVar m++-- | Replaces the value (since it was locked for potential writers) and unlocks writers.+putXMVarWrite :: XMVar a -> a -> IO ()+putXMVarWrite (XMVar m l) v+  = swapMVar m v >> putMVar l ()++-- | Locks for both reads and writes ('MVar' behaviour).+--   This may be useful to save space because the old @a@ does not have to be kept in memory for+--   read access. Note that references to the old @a@ might still lead to memory leaks/issues.+takeXMVarLock :: XMVar a -> IO a+takeXMVarLock (XMVar m l)+  = takeMVar l >> takeMVar m++-- | Replaces the value (since it was locked for potential writers) and unlocks writers.+putXMVarLock :: XMVar a -> a -> IO ()+putXMVarLock (XMVar m l) v+  = putMVar m v >> putMVar l ()++-- ------------------------------------------------------------
+ src/Data/Bijection.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE MultiParamTypeClasses #-}++-- ----------------------------------------------------------------------------+{- |+'Bijection' instances represent a bijection between two types and allow conversion to and from.+-}+-- ----------------------------------------------------------------------------++module Data.Bijection where++-- | Bijection between two types @a@ and @b@.+--   'to' and 'from' represent the bijective function.+--+-- For a proper bijection between x and y, two instances need to be defined (@Bijection x y@ and+-- @Bijection y x@).+class Bijection a b where+  to   :: a -> b+  from :: b -> a++-- This works, but requires XFlexibleInstances XUndecidableInstances which causes errors not being+-- checked by the compiler. Probably because the constraint is not smaller than the head (Paterson-+-- Condition?), which is allowed with XUndecidableInstances.+{-+-- | Only one way needs to be defined.+instance Bijection a b => Bijection b a where+  to   = from+  from = to+-}++-- ------------------------------------------------------------
+ src/Data/Bijection/Instances.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS -fno-warn-orphans     #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverlappingInstances  #-}++-- ----------------------------------------------------------------------------+{- |+  Default 'Bijection' instances.+-}+-- ----------------------------------------------------------------------------++module Data.Bijection.Instances where++import           Data.Text++import           Data.Bijection++-- ------------------------------------------------------------++-- | 'Text' to 'String'.+instance Bijection Text String where+  to   = unpack+  from = pack++-- | 'String' to 'Text'.+instance Bijection String Text where+  to   = pack+  from = unpack++-- ------------------------------------------------------------
+ src/Data/IntMap/BinTree/Strict.hs view
@@ -0,0 +1,700 @@+{-# LANGUAGE BangPatterns       #-}+{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveDataTypeable #-}++module Data.IntMap.BinTree.Strict where++import           Control.Applicative (Applicative (..), (<$>))+import           Control.DeepSeq+import           Control.Monad++import           Data.Binary         (Binary (..), getWord8)+import qualified Data.Foldable       as F+import qualified Data.IntSet         as S+import qualified Data.List           as L+import           Data.Traversable    (Traversable (..))+import           Data.Typeable+import           Data.Word           (Word8)++import           Prelude             hiding (foldl, foldr, lookup, map, null)++moduleName :: String+moduleName = "Data.IntMap.BinTree.Strict"++error' :: String -> a+error' = error . ((moduleName ++": ") ++)++-- ------------------------------------------------------------++type Key = Int++type IntMap v = Tree v++data Tree v = Empty+            | Node !Key !v !(Tree v) !(Tree v)+            | Lt   !Key !v !(Tree v)            -- Lt, Gt and Leaf are special cases+            | Gt   !Key !v           !(Tree v)  -- of Node to get rid of the empty trees+            | Leaf !Key !v                      -- Empty occurs only as root, never as subtree+              deriving (Show, Typeable)         -- This saves 20% of space, average size of+                                                -- objects is 4 instead of 5 words++-- ------------------------------------------------------------+--+-- instances for NFData and Binary++instance Eq v => Eq (Tree v) where+    (==) = equal++instance NFData v => NFData (Tree v) where+    rnf (Node _k v l r) = rnf v `seq` rnf l `seq` rnf r+    rnf (Lt   _k v l  ) = rnf v `seq` rnf l+    rnf (Gt   _k v   r) = rnf v `seq`             rnf r+    rnf (Leaf _k v    ) = rnf v+    rnf Empty           = ()++instance Binary v => Binary (Tree v) where+    put (Empty       ) = put (0::Word8)+    put (Node k v l r) = put (1::Word8) >> put k >> put v >> put l >> put r+    put (Lt   k v l  ) = put (2::Word8) >> put k >> put v >> put l+    put (Gt   k v   r) = put (3::Word8) >> put k >> put v          >> put r+    put (Leaf k v    ) = put (4::Word8) >> put k >> put v++    get = do tag <- getWord8+             case tag of+               0 -> return Empty+               1 -> Node <$> get <*> get <*> get <*> get+               2 -> Lt   <$> get <*> get <*> get+               3 -> Gt   <$> get <*> get         <*> get+               4 -> Leaf <$> get <*> get+               _ -> error' "error in \"get\" while decoding BinTree"++instance Functor Tree where+    fmap = map++instance F.Foldable Tree where+    foldr  = foldr+    foldl  = foldl+    foldr' = foldr'+    foldl' = foldl'++    {-# INLINE foldr    #-}+    {-# INLINE foldl    #-}+    {-# INLINE foldr'   #-}+    {-# INLINE foldl'   #-}++instance Traversable Tree where+    traverse f (Node k v l r) = Node k <$> f v <*> traverse f l <*> traverse f r+    traverse f (Lt   k v l  ) = Lt   k <$> f v <*> traverse f l+    traverse f (Gt   k v   r) = Gt   k <$> f v                  <*> traverse f r+    traverse f (Leaf k v    ) = Leaf k <$> f v+    traverse _ (Empty       ) = pure Empty++traverseWithKey :: Applicative t => (Key -> a -> t b) -> Tree a -> t (Tree b)+traverseWithKey f+    = go+    where+      go Empty = pure Empty+      go t     = mkNode k <$> f k v <*> go l <*> go r+                 where+                   (k, v, l, r) = unNode t++--       = (pure DIM <*>) . IM.traverseWithKey f . unDIM++-- ------------------------------------------------------------+--+-- the smart constructor generating Lt, Gt and Leaf nodes++mkNode :: Key -> v -> Tree v -> Tree v -> Tree v+mkNode k v Empty Empty = Leaf k v+mkNode k v Empty r     = Gt   k v   r+mkNode k v l     Empty = Lt   k v l+mkNode k v l     r     = Node k v l r++{-# INLINE mkNode #-}+++-- the smart destructor for normalization of Lt, Gt and Leaf nodes++unNode :: Tree v -> (Key, v, Tree v, Tree v)+unNode (Node k v l r) = (k, v, l,     r    )+unNode (Lt   k v l  ) = (k, v, l,     Empty)+unNode (Gt   k v   r) = (k, v, Empty, r    )+unNode (Leaf k v    ) = (k, v, Empty, Empty)+unNode  Empty         = error' "\"unNode\" with empty tree"++{-# INLINE unNode #-}++-- ------------------------------------------------------------+--+-- the work horses++split' :: Key -> Tree v -> (Maybe v, Tree v, Tree v)+split' _ Empty+    = (Nothing, Empty, Empty)++split' k t+    = case compare k k' of+        LT -> let (v', l', r') = split' k l+              in  (v', l', mkNode k' v r' r)++        EQ -> (Just v, l, r)++        GT -> let (v', l', r') = split' k r+              in  (v', mkNode k' v l l', r')+      where+        (k', v, l, r) = unNode t++join' :: Maybe (Key, v) -> Tree v -> Tree v -> Tree v+join' (Just (k, v)) t1 t2+    = mkNode k v t1 t2++join' Nothing t1 t2+    = case minViewWithKey t2 of                 -- get smallest key in t2+        Nothing          -> t1                  -- and return t1+        Just ((k, v), r) -> mkNode k v t1 r     -- or take that key as new root++{- disabled due to unbalancing of result tree++join' Nothing t1 t2+    = go t1+      where+        go Empty = t2                           -- insert whole t2 at the rightmost node in t1+        go t     = mkNode k v l (go r)          -- balancing ???+                   where+                     (k, v, l, r) = unNode t+-- -}++{-# INLINE join' #-}++-- ------------------------------------------------------------+{-+-- lookup, insert and delete with split' and join'+-- insert and delete change the root+-- and can lead to stronger unbalancing than trad. insert and delete++lookup :: Key -> Tree v -> Maybe v+lookup k t+    = v+      where+        (v, _l, _r) = split' k t++insertWith :: (v -> v -> v) -> Key -> v -> Tree v -> Tree v+insertWith f k v t+    = join' (Just (k, f' v')) l r+      where+        (v', l, r)    = split' k t+        f' Nothing    =       v+        f' (Just v'') = f v'' v++delete :: Key -> Tree v -> Tree v+delete k t+    = join' Nothing l r+      where+        (_, l, r) = split' k t++{-# INLINE lookup     #-}+{-# INLINE insertWith #-}+{-# INLINE delete     #-}++-- -}+-- ------------------------------------------------------------+-- {-+-- traditional lookup, insert and remove++lookup :: Key -> Tree v -> Maybe v+lookup k+    = go+      where+        go Empty = Nothing+        go t     = case compare k k' of+                     LT -> go l+                     EQ -> Just v+                     GT -> go r+                   where+                     (k', v, l, r) = unNode t++insertWith :: (v -> v -> v) -> Key -> v -> Tree v -> Tree v+insertWith f k v+    = ins+    where+      ins Empty = mkNode k v Empty Empty+      ins t     = case compare k k' of+                    LT -> mkNode k' v'      (ins l)      r+                    EQ -> mkNode k (f v v')      l       r+                    GT -> mkNode k' v'           l  (ins r)+                  where+                    (k', v', l, r) = unNode t++delete :: Key -> Tree v -> Tree v+delete k+    = del+    where+      del Empty = Empty+      del t     = case compare k k' of+                    LT -> mkNode k' v' (del l) r+                    EQ -> case minViewWithKey r of+                            Nothing               -> Empty+                            Just ((k'', v''), r') -> mkNode k'' v'' l r'+                    GT -> mkNode k' v' l (del r)+                  where+                    (k', v', l, r) = unNode t++{-# INLINE lookup          #-}+{-# INLINE insertWith      #-}+{-# INLINE delete          #-}++-- -}+-- ------------------------------------------------------------+--+-- derived lookup and insert functions++find :: Key -> Tree v -> v+find k = maybe notThere id . lookup k+    where+      notThere = error' ( "error in find: key "+                         ++ show k+                         ++ " is not an element of the map"+                       )++findWithDefault :: v -> Key -> Tree v -> v+findWithDefault v k = maybe v id . lookup k++member :: Key -> Tree v -> Bool+member k = maybe False (const True) . lookup k++notMember :: Key -> Tree v -> Bool+notMember k = maybe True (const False) . lookup k+++insert :: Key -> v -> Tree v -> Tree v+insert = insertWith const+++{-# INLINE find            #-}+{-# INLINE findWithDefault #-}+{-# INLINE member          #-}+{-# INLINE notMember       #-}+{-# INLINE insert          #-}++-- ------------------------------------------------------------+--+-- primitive operations++empty :: Tree v+empty = Empty++null :: Tree v -> Bool+null Empty = True+null _     = False++size :: Tree v -> Int+size = foldl' (\ cnt _ -> cnt + 1) 0++-- | retuns the size of a tree or Nothing if @size t > limit@+--+-- limits the computation time to O(limit), not O(size)++sizeWithLimit :: Int -> Tree v -> Maybe Int+sizeWithLimit limit+    = go 0+    where+      go !i Empty+          = return i+      go !i t+          | i == limit+              = mzero+          | otherwise+              = do i' <- go (i+1) l+                   go i' r+          where+            (_k, _v, l, r) = unNode t++-- ------------------------------------------------------------++union :: Tree v -> Tree v -> Tree v+union = unionWith const++unionWith :: (v -> v -> v) -> Tree v -> Tree v -> Tree v+unionWith op+    = unionWithKey (const op)++unionWithKey' :: (Key -> v -> v -> v) -> Tree v -> Tree v -> Tree v+unionWithKey' _  x1 Empty+    = x1+unionWithKey' f x1 x2+    = uni x1 x2+    where+      uni Empty t2 = t2+      uni t1    t2 = join' (Just (k, v')) (uni l l') (uni r r')+                     where+                       (k, v, l, r) = unNode t1+                       (m', l', r') = split' k t2+                       v'           = maybe v (f k v) m'++unionsWith :: (v -> v -> v) -> [Tree v] -> Tree v+unionsWith f = L.foldl' (\ acc t -> unionWith f acc t) empty++{-# INLINE union         #-}+{-# INLINE unionWith     #-}+{-# INLINE unionWithKey' #-}++-- ------------------------------------------------------------++difference :: Tree a -> Tree b -> Tree a+difference = differenceWith (const (const Nothing))++differenceWith :: (a -> b -> Maybe a) -> Tree a -> Tree b -> Tree a+differenceWith op+    = differenceWithKey (const op)++differenceWithKey' :: (Key -> a -> b -> Maybe a) -> Tree a -> Tree b -> Tree a+differenceWithKey' _ x1 Empty+    = x1++differenceWithKey' f x1 x2+    = diff x1 x2+    where+      diff Empty _  = Empty+      diff t1    t2 = join' v' (diff l l') (diff r r')+                      where+                        (k, v, l, r) = unNode t1+                        (m', l', r') = split' k t2+                        v'           = case m' of+                                          Nothing -> Just (k, v)+                                          Just x  -> case f k v x of+                                                       Nothing -> Nothing+                                                       Just y  -> Just (k, y)++{-# INLINE difference         #-}+{-# INLINE differenceWith     #-}+{-# INLINE differenceWithKey' #-}++-- ------------------------------------------------------------++intersection :: Tree a -> Tree b -> Tree a+intersection = intersectionWith const++intersectionWith :: (a -> b -> c) -> Tree a -> Tree b -> Tree c+intersectionWith op+    = intersectionWithKey (const op)++intersectionWithKey' :: (Key -> a -> b -> c) -> Tree a -> Tree b -> Tree c+intersectionWithKey' _  _ Empty+    = Empty+intersectionWithKey' f x1 x2+    = intersect x1 x2+    where+      intersect Empty _  = Empty+      intersect t1    t2 = join' kv' (intersect l l') (intersect r r')+                           where+                             (k, v, l, r) = unNode t1+                             (m', l', r') = split' k t2+                             kv'          = (\ y -> (k, f k v y)) <$> m'++{-# INLINE intersection         #-}+{-# INLINE intersectionWith     #-}+{-# INLINE intersectionWithKey' #-}++equal :: Eq v => Tree v -> Tree v -> Bool+equal Empty Empty = True+equal Empty _t2   = False+equal _t1   Empty = False+equal t1 t2       =    Just v1 == m2+                    && l1 `equal` l2+                    && r1 `equal` r2+                    where+                      (k1, v1, l1, r1) = unNode t1+                      (m2,     l2, r2) = split' k1 t2++-- ------------------------------------------------------------+--+-- maps++map :: (a -> b) -> Tree a -> Tree b+map f = mapWithKey (const f)++mapWithKey :: (Key -> a -> b) -> Tree a -> Tree b+mapWithKey f+    = mp+    where+      mp Empty = Empty+      mp t     = mkNode k (f k v) (mp l) (mp r)+                 where+                   (k, v, l, r) = unNode t++{-# INLINE map                  #-}+{-# INLINE mapWithKey           #-}++-- ------------------------------------------------------------+-- filter++filter :: (a -> Bool) -> Tree a -> Tree a+filter p = filterWithKey (\ _k v -> p v)++filterWithKey :: (Key -> a -> Bool) -> Tree a -> Tree a+filterWithKey p+    = go+    where+      go Empty = Empty+      go t     = join' res (go l) (go r)+                 where+                   (k, v, l, r)    = unNode t+                   res | p k v     = Just (k, v)+                       | otherwise = Nothing++{-# INLINE filter               #-}+{-# INLINE filterWithKey        #-}++-- ------------------------------------------------------------+--+-- foldr's++foldr :: (a -> b -> b) -> b -> Tree a -> b+foldr op = foldrWithKey (const op)++foldr' :: (a -> b -> b) -> b -> Tree a -> b+foldr' op = foldrWithKey' (const op)++foldrWithKey :: (Key -> a -> b -> b) -> b -> Tree a -> b+foldrWithKey f+    = fold+    where+      fold acc Empty = acc+      fold acc t     = fold (f k v (fold acc r)) l+                       where+                         (k, v, l, r) = unNode t++foldrWithKey' :: (Key -> a -> b -> b) -> b -> Tree a -> b+foldrWithKey' f+    = fold+    where+      fold !acc Empty = acc+      fold !acc t     = fold (f k v (fold acc r)) l+                        where+                          (k, v, l, r) = unNode t++-- ------------------------------------------------------------+--+-- foldl's++foldl :: (b -> a -> b) -> b -> Tree a -> b+foldl op = foldlWithKey (\ x _k v -> op x v)++foldl' :: (b -> a -> b) -> b -> Tree a -> b+foldl' op = foldlWithKey (\ x _k v -> op x v)++foldlWithKey :: (b -> Key -> a -> b) -> b -> Tree a -> b+foldlWithKey f+    = fold+    where+      fold acc Empty = acc+      fold acc t     = fold (f (fold acc l) k v) r+                       where+                         (k, v, l, r) = unNode t++foldlWithKey' :: (b -> Key -> a -> b) -> b -> Tree a -> b+foldlWithKey' f+    = fold+    where+      fold !acc Empty = acc+      fold !acc t     = fold (f (fold acc l) k v) r+                        where+                          (k, v, l, r) = unNode t++{-# INLINE foldr        #-}+{-# INLINE foldrWithKey #-}+{-# INLINE foldl        #-}+{-# INLINE foldlWithKey #-}++-- ------------------------------------------------------------++fromList :: [(Key, v)] -> Tree v+fromList = L.foldl' (\ acc (k, v) -> insert k v acc) Empty++fromSet :: (Key -> v) -> S.IntSet -> Tree v+fromSet f = fromAscList . L.map (\ k -> (k, f k)) . S.elems++fromAscList :: [(Key, v)] -> Tree v+fromAscList = toTr 0 Empty++-- accumulates a balanced tree from a list+-- by scanning the list just once+-- the input tree t has depth i++toTr :: Int -> Tree v -> [(Key, v)] -> Tree v+toTr _ t [] = t+toTr i t (x : xs)+    | L.null xs1  = t'+    | otherwise = toTr (i + 1) t' xs1+    where+      (r, xs1) = scan i xs+      t'       = join' (Just x) t r++-- builds a tree of depth i from the first 2^i - 1 elements of xs+-- and returns the tree and the remaining list++scan :: Int -> [(Key, v)] -> (Tree v, [(Key, v)])+scan 0 xs       = (Empty, xs)+scan _ []       = (Empty, [])+scan i xs+    | L.null xs1  = (l, [])+    | otherwise = (join' (Just x) l r, xs3)+    where+      (l,  xs1) = scan (i - 1) xs+      (x : xs2) = xs1+      (r,  xs3) = scan (i - 1) xs2++-- ------------------------------------------------------------+--+-- conversions to lists++toAscList :: Tree v -> [(Key, v)]+toAscList = foldrWithKey (\ k v res -> (k, v) : res) []++toList :: Tree v -> [(Key, v)]+toList = toAscList++assocs :: Tree v -> [(Key, v)]+assocs = toAscList++elems :: Tree v -> [v]+elems = foldr (:) []++keys :: Tree v -> [Key]+keys = foldrWithKey (\ k _v r -> k : r) []++{-# INLINE toAscList #-}+{-# INLINE toList #-}+{-# INLINE assocs #-}+{-# INLINE elems #-}+{-# INLINE keys  #-}++-- ------------------------------------------------------------+--+-- min/max++minView :: Tree v -> Maybe (v, Tree v)+minView t = first snd <$> minViewWithKey t++minViewWithKey :: Tree v -> Maybe ((Key, v), Tree v)+minViewWithKey Empty = Nothing+minViewWithKey x     = Just $ go x+    where+      go t = case l of+               Empty -> ((k, v), r)+               _     -> substLeft $ go l+          where+            (k, v, l, r) = unNode t+            substLeft (kv, l') = (kv, mkNode k v l' r)++maxView :: Tree v -> Maybe (v, Tree v)+maxView t = first snd <$> maxViewWithKey t++maxViewWithKey :: Tree v -> Maybe ((Key, v), Tree v)+maxViewWithKey Empty = Nothing+maxViewWithKey x     = Just $ go x+    where+      go t = case r of+               Empty -> ((k, v), l)+               _     -> substRight $ go r+          where+            (k, v, l, r) = unNode t+            substRight (kv, r') = (kv, mkNode k v l r')++{-# INLINE minView        #-}+{-# INLINE maxView        #-}+{-# INLINE minViewWithKey #-}+{-# INLINE maxViewWithKey #-}++first :: (a -> c) -> (a, b) -> (c, b)+first f (x,y) = (f x,y)++{-# INLINE first #-}++-- ------------------------------------------------------------++unionWithKey        :: (Key -> v -> v -> v) -> Tree v -> Tree v -> Tree v+intersectionWithKey :: (Key -> a -> b -> c) -> Tree a -> Tree b -> Tree c+differenceWithKey   :: (Key -> a -> b -> Maybe a) -> Tree a -> Tree b -> Tree a++-- {-+unionWithKey        = unionWithKey'+intersectionWithKey = intersectionWithKey'+differenceWithKey   = differenceWithKey'++-- -}++{- union, interect and diff operations with assertions++unionWithKey op+    = assertBin "unionWithKey" keys keys keys union'keys $ unionWithKey' op+      where+        union'keys x y = L.sort $ x `L.union` y++differenceWithKey op+    = assertBin "differenceWithKeys" keys keys keys diff'keys $ differenceWithKey' op+      where+        diff'keys x y = L.sort $ x L.\\ y++intersectionWithKey op+    = assertBin "intersectionWithKey" keys keys keys intersection'keys $ intersectionWithKey' op+      where+        intersection'keys x y = L.sort $ x `L.intersect` y++assertBin :: (Eq r, Show r) =>+             String -> (a -> r) -> (b -> r) -> (c -> r) -> (r -> r -> r) ->+             (a -> b -> c) -> (a -> b -> c)+assertBin opn retrX retrY retrR op' op x y+    = assert msg' retrR res' res+    where+      res  = x  `op`  y+      res' = x' `op'` y'+      x'   = retrX x+      y'   = retrY y+      msg' = unlines [ "operation: " ++ opn+                     , "arg1:      " ++ show x'+                     , "arg2:      " ++ show y'+                     ]++assert :: (Eq r, Show r) => String -> (a -> r) -> r -> a -> a+assert args retr exp' res+    | exp' == res' = res+    | otherwise    = error msg+    where+      res' = retr res+      msg  = unlines [ "assertion failed"+                     , args+                     , "expected:  " ++ show exp'+                     , "got:       " ++ show res'+                     ]+-- -}++-- ------------------------------------------------------------+{-++main :: IO ()+main = return ()++fromList' :: [Key] -> Tree String+fromList' = fromAscList . L.map (\ x -> (x, ""))+fromList'' :: [Key] -> Tree String+fromList'' = fromList . L.map (\ x -> (x, show $ x+1))++s1 :: Tree String+s1 = fromList' [2,4..10]+s2 :: Tree String+s2 = fromList' [1,3..10]+s3 :: Tree String+s3 = fromList'' [0,3..10]+++arg1 = fromList' [-9019555248142772964,-6161526110399673733,-5962998868550245357,-5723094145863444326,-5358586818353638861,-4957792663758460317,-1038248931000888297,1160546946948583692,1945733972938829115,2251145106674145554,3000418586234587927,4084681012873670518,5287472037333007190,7296040159437125633,8079593536333253132,8492044343351169705]+arg2 = fromList' [-9019555248142772964,-6161526110399673733,-5358586818353638861,-4957792663758460317,-1038248931000888297,1160546946948583692,1945733972938829115,2251145106674145554,3000418586234587927,4084681012873670518,5287472037333007190,7296040159437125633,8079593536333253132,8492044343351169705]++expected = fromList'  [-9019555248142772964,-6161526110399673733,-5358586818353638861,-4957792663758460317,-1038248931000888297,1160546946948583692,1945733972938829115,2251145106674145554,3000418586234587927,4084681012873670518,5287472037333007190,7296040159437125633,8079593536333253132,8492044343351169705]+got = fromList'       [-9019555248142772964,-6161526110399673733,-5358586818353638861,-4957792663758460317,-1038248931000888297]+++-- -}++-- ------------------------------------------------------------
+ src/Data/IntSet/Cache.hs view
@@ -0,0 +1,42 @@+-- ----------------------------------------------------------------------------+{- |+A cache for single element 'IntSet's with elements 0 <= i < cacheSize (1024)+These single element sets occur very frequently in position sets+in occurrence maps, so sharing becomes available with this cache.++Usage: substitute all singleton calls with @cacheAt@ calls+and all @fromList@ calls with @IS.unions . map cacheAt@.+-}+-- ----------------------------------------------------------------------------++module Data.IntSet.Cache+  ( cache+  , cacheAt+  )+where+import           Control.DeepSeq++import qualified Data.IntSet     as S+import qualified Data.Vector     as V++-- ------------------------------------------------------------++-- | Size of the cache.+cacheSize :: Int+cacheSize = 1024++-- | Initialize the 'IntSet' cache.+cache :: V.Vector S.IntSet+cache = id $!! V.generate cacheSize S.singleton++-- | A (cached) 'IntSet' singleton.+cacheAt :: Int -> S.IntSet+cacheAt i+    | 0 <= i+      &&+      i < cacheSize+          = id $! cache V.! i+    | otherwise+        = id $! S.singleton i++-- ------------------------------------------------------------
+ src/Data/LimitedPriorityQueue.hs view
@@ -0,0 +1,137 @@+-- ----------------------------------------------------------------------------++{- |+   Intermediate data structure for sorting and paging a result set++   When sorting a result set by priority and knowing how many+   results are requested and which "page" of the result set+   is requested, a priority queue with limited capacity can be used+   for efficient sorting and paging.++-}++module Data.LimitedPriorityQueue+    ( Queue+    , mkQueue+    , insert+    , reduce+    , toList+    , fromList+    , pageList+    )+where++import           Prelude hiding (drop, take)++-- ----------------------------------------------------------------------------++data Queue v+    = Q { _capacity :: !Int+        , _size     :: !Int+        , _elems    :: (Heap v)+        }+      deriving (Show)++data Heap v+    = E+    | T v (Heap v) (Heap v)+      deriving (Show)++-- | Create an empty priority queue with a limited capacity.+-- If capacity is < 0, no limit is set++mkQueue :: Int -> Queue v+mkQueue c+    | c >= 0+        = Q c 0 E+    | otherwise+        = Q maxBound 0 E++-- | Insert an element if there is space in the queue+-- or if the element is larger than the smallest element.++insert :: Ord v => v -> Queue v -> Queue v+insert x q@(Q c s h)+    | s < c                     -- capacity not reached: insert+        = Q c (s + 1) (merge h (T x E E))+    | x' >= x                   -- queue full, score < min score: don't insert+        = q+    | otherwise                 -- queue full, score >= min: throw min away and insert+        = Q c s (merge (merge l r) (T x E E))+    where+      (T x' l r) = h++-- | Reduce size and capacity of queue+-- by throwing away small elements.++reduce :: Ord v => Int -> Queue v -> Queue v+reduce i (Q _ s h)+    | i >= s+        = Q i s h+    | otherwise -- i < s+        = Q i i (drop (s - i) h)++toList :: Ord v => Int -> Int -> Queue v -> [v]+toList start len (Q _ s h)+    | len < 0                   -- no limit on the length, take all except the first elems+        = take (s - start) h+    | len' < s                  -- more elements in queue than needed, drop some elems+        = take len $ drop (s - len') h+    | otherwise                 -- less elements in queue, take them+        = take (len - (len' - s)) h+      where+        len' = start + len++fromList :: Ord v => Int -> [v] -> Queue v+fromList c+    = foldl (\ q x -> insert x q) (mkQueue c)++-- | Take a list of scored values, sort it and return a page of the result.+--+-- @pageList 10 5 xs == take 5 . drop 10 . sortBy snd $ xs@+--+-- If the length is set to @-1@ no limit on the page length is set.++pageList :: Ord v => Int -> Int -> [v] -> [v]+pageList start len+    = toList start len . fromList len'+    where+      len'+          | len >= 0  = start + len+          | otherwise = len++-- ----------------------------------------------------------------------------+-- skew heap operations++take :: Ord v => Int -> Heap v -> [v]+take i0 h0+    = take' i0 h0 []+    where+      take' i (T x l r) acc+          | i <= 0+              = acc+          | otherwise+              = take' (i - 1) (merge l r) (x : acc)+      take' _ E acc+            = acc++drop :: Ord v => Int -> Heap v -> Heap v+drop i h+    | i <= 0+        = h+    | otherwise+        = drop (i - 1) (merge l r)+    where+      (T _x l r) = h++merge :: Ord v => Heap v -> Heap v -> Heap v+merge E q2 = q2+merge q1 E = q1+merge q1@(T x1 l1 r1) q2@(T x2 l2 r2)+    | x1 <= x2+        = T x1 r1 (merge l1 q2)+    | otherwise+        = T x2 r2 (merge l2 q1)++-- ----------------------------------------------------------------------------+
+ src/Data/Text/Binary.hs view
@@ -0,0 +1,23 @@+{-# OPTIONS -fno-warn-orphans #-}++-- ----------------------------------------------------------------------------+{- |+Default 'Binary' instance for 'Text' using UTF-8.+-}+-- ----------------------------------------------------------------------------++module Data.Text.Binary+where++import           Control.Monad      (liftM)+import           Data.Binary        (Binary (..))+import           Data.Text+import           Data.Text.Encoding++-- ------------------------------------------------------------++instance Binary Text where+  put = put . encodeUtf8+  get = liftM decodeUtf8 get++-- ------------------------------------------------------------
+ src/Data/Typeable/Binary.hs view
@@ -0,0 +1,28 @@+{-# OPTIONS -fno-warn-orphans #-}++-- ----------------------------------------------------------------------------+{- |+'Binary' instance for 'TypeRep'.+-}+-- ----------------------------------------------------------------------------++module Data.Typeable.Binary where++import           Control.Applicative++import           Data.Binary+import           Data.Typeable.Internal++import           GHC.Fingerprint.Binary ()++-- ------------------------------------------------------------++instance Binary TypeRep where+  put (TypeRep fp tyCon ts) = put fp >> put tyCon >> put ts+  get = TypeRep <$> get <*> get <*> get++instance Binary TyCon where+  put (TyCon hash package modul name) = put hash >> put package >> put modul >> put name+  get = TyCon <$> get <*> get <*> get <*> get++-- ------------------------------------------------------------
+ src/GHC/Fingerprint/Binary.hs view
@@ -0,0 +1,23 @@+{-# OPTIONS -fno-warn-orphans #-}++-- ----------------------------------------------------------------------------+{- |+'Binary' instance for 'Fingerprint'.+-}+-- ----------------------------------------------------------------------------++module GHC.Fingerprint.Binary where++import           Control.Applicative++import           Data.Binary++import           GHC.Fingerprint.Type++-- ------------------------------------------------------------++instance Binary Fingerprint where+  put (Fingerprint hi lo) = put hi >> put lo+  get = Fingerprint <$> get <*> get++-- ------------------------------------------------------------
+ src/GHC/Stats/Json.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS -fno-warn-orphans #-}++-- ----------------------------------------------------------------------------+{- |+'ToJSON' instance for 'GCStats'.+-}+-- ----------------------------------------------------------------------------++module GHC.Stats.Json where++import           Data.Aeson++import           GHC.Stats++-- ------------------------------------------------------------++instance ToJSON GCStats where+  toJSON o = object+    [ "bytesAllocated"          .= bytesAllocated o+    , "numGcs"                  .= numGcs o+    , "maxBytesUsed"            .= maxBytesUsed o+    , "numByteUsageSamples"     .= numByteUsageSamples o+    , "cumulativeBytesUsed"     .= cumulativeBytesUsed o+    , "bytesCopied"             .= bytesCopied o+    , "currentBytesUsed"        .= currentBytesUsed o+    , "currentBytesSlop"        .= currentBytesSlop o+    , "maxBytesSlop"            .= maxBytesSlop o+    , "peakMegabytesAllocated"  .= peakMegabytesAllocated o+    , "mutatorCpuSeconds"       .= mutatorCpuSeconds o+    , "mutatorWallSeconds"      .= mutatorWallSeconds o+    , "gcCpuSeconds"            .= gcCpuSeconds o+    , "gcWallSeconds"           .= gcWallSeconds o+    , "cpuSeconds"              .= cpuSeconds o+    , "wallSeconds"             .= wallSeconds o+    , "parTotBytesCopied"       .= parTotBytesCopied o+    , "parMaxBytesCopied"       .= parMaxBytesCopied o+    ]++-- ------------------------------------------------------------
+ src/Hunt/ClientInterface.hs view
@@ -0,0 +1,520 @@+{- |+  Module     : Hunt.ClientInterface+  License    : MIT++  Maintainer : Uwe Schmidt+  Stability  : experimental+  Portability: none portable++  Common data types and and smart constructors+  for calling a hunt server from a client.++  Values of the Command datatype and its component types, e.g+  Query, ApiDocument, and others+  can be constructed with the "smart" construtors+  defined in this module++  The module is intended to be imported qualified,+  eg like @import qualified Hunt.ClientInterface as HI@.++-}++-- ----------------------------------------------------------------------------++module Hunt.ClientInterface+    (+    -- * types used in commands+      Command+    , ApiDocument(..)   -- also used in results+    , Huntable(..)+    , Content+    , Context+    , ContextSchema+    , Description+    , IndexMap+    , RegEx+    , StatusCmd+    , URI+    , Weight++    -- * types used in results+    , CmdError(..)+    , CmdRes(..)+    , CmdResult(..)+    , LimitedResult(..)+    , Score++    -- * command construction+    , cmdSearch+    , cmdCompletion+    , cmdSelect+    , cmdInsertDoc+    , cmdUpdateDoc+    , cmdDeleteDoc+    , cmdDeleteDocsByQuery+    , cmdLoadIndex+    , cmdStoreIndex+    , cmdInsertContext+    , cmdDeleteContext+    , cmdStatus+    , cmdSequence+    , cmdNOOP++    -- ** configuration options for search and completion+    , setSelectedFields+    , setMaxResults+    , setResultOffset+    , setWeightIncluded++    -- ** Misc+    , createContextCommands+++    -- * ApiDocument construction, configuration and access+    , mkApiDoc+    , setDescription+    , getDescription+    , addDescription+    , remDescription+    , changeDescription+    , lookupDescription+    , lookupDescriptionText+    , setIndex+    , addToIndex+    , getFromIndex+    , changeIndex+    , setDocWeight++    -- ** Misc+    , listToApiDoc+    , insertCmdsToDocuments++    -- ** description construction+    , mkDescription+    , mapToDescr+    , insDescription+    , emptyDescription+    , fromDescription++    -- * Queries+    , Query+    -- ** query parsing+    , parseQuery+    -- ** query construction+    , module Hunt.Query.Language.Builder+++    -- ** pretty printing+    , printQuery++    -- ** query completion+    , completeQueries++    -- * schema definition+    , mkSchema+    , setCxNoDefault+    , setCxWeight+    , setCxRegEx+    , setCxUpperCase+    , setCxLowerCase+    , setCxZeroFill+    , setCxText+    , setCxInt+    , setCxDate+    , setCxPosition++    -- * Weights and Scores+    , noScore+    , defScore+    , mkScore+    , getScore++--    -- * Output to server and file+--    , sendCmdToServer+    , sendCmdToFile+--    , defaultServer+    )+where++import           Control.Applicative         ((<$>))+import           Data.Aeson                  (FromJSON (..), ToJSON (..), Value(..))+import           Data.Default+import           Data.List                   (nub)+import qualified Data.Map.Strict             as SM+import qualified Data.Map.Lazy               as LM+import           Data.Text                   (Text)+import qualified Data.Text                   as T++import           Hunt.Common.ApiDocument     (ApiDocument (..), IndexMap,+                                              LimitedResult (..),+                                              emptyApiDocDescr,+                                              emptyApiDocIndexMap)+import           Hunt.Common.BasicTypes      (Content, Context, Description,+                                              RegEx, Score, URI, Weight,+                                              defScore, getScore, mkScore,+                                              noScore)+import qualified Hunt.Common.DocDesc         as DD+import           Hunt.Index.Schema+import           Hunt.Interpreter.Command+import           Hunt.Query.Language.Builder+import           Hunt.Query.Language.Grammar+import           Hunt.Query.Language.Parser  (parseQuery)+import           Hunt.Utility.Output         (outputValue)++-- ------------------------------------------------------------+-- lookup commands++class Huntable x where+  huntURI        :: x -> URI++  huntIndexMap   :: x -> IndexMap+  huntIndexMap _ = emptyApiDocIndexMap++  huntDescr      :: x -> Description+  huntDescr _    = emptyApiDocDescr++  toApiDocument  :: x -> ApiDocument+  toApiDocument  x = setDescription (huntDescr x) $+                     setIndex (huntIndexMap x) $+                     mkApiDoc $ (huntURI x)+++-- | create simple search command++cmdSearch :: Query -> Command+cmdSearch q+    = Search { icQuery    = q+             , icOffsetSR = 0+             , icMaxSR    = (-1)        -- unlimited+             , icWeight   = False+             , icFields   = Nothing+             }++-- | Create simple completion command++cmdCompletion :: Query -> Command+cmdCompletion q+    = Completion { icPrefixCR = q+                 , icMaxCR    = (-1)    -- unlimited+                 }++cmdSelect :: Query -> Command+cmdSelect = Select++-- ------------------------------------------------------------+-- modifying commands++-- | insert document++cmdInsertDoc :: ApiDocument -> Command+cmdInsertDoc = Insert++-- | update document++cmdUpdateDoc :: ApiDocument -> Command+cmdUpdateDoc = Update++-- | delete document identified by an URI++cmdDeleteDoc :: URI -> Command+cmdDeleteDoc = Delete++-- | delete all documents idenitfied by a query++cmdDeleteDocsByQuery :: Query -> Command+cmdDeleteDocsByQuery = DeleteByQuery++-- ------------------------------------------------------------+-- index schema manipulation++cmdInsertContext :: Context -> ContextSchema -> Command+cmdInsertContext cx sc+    = InsertContext { icIContext = cx+                    , icSchema   = sc+                    }++cmdDeleteContext :: Context -> Command+cmdDeleteContext cx+    = DeleteContext { icDContext = cx }++-- ------------------------------------------------------------+-- index persistance++cmdLoadIndex :: FilePath -> Command+cmdLoadIndex = LoadIx++cmdStoreIndex :: FilePath -> Command+cmdStoreIndex = StoreIx++-- ------------------------------------------------------------+-- status and control commands++cmdStatus :: StatusCmd -> Command+cmdStatus = Status++cmdSequence :: [Command] -> Command+cmdSequence []  = cmdNOOP+cmdSequence [c] = c+cmdSequence cs  = Sequence cs++cmdNOOP :: Command+cmdNOOP = NOOP++-- ------------------------------------------------------------++-- | configure search and completion command: set the max # of results++setMaxResults :: Int -> Command -> Command+setMaxResults mx q@Search{}+    = q { icMaxSR    = mx }+setMaxResults mx q@Completion{}+    = q { icMaxCR    = mx }+setMaxResults _ q+    = q++-- | configure search command: set the starting offset of the result list+setResultOffset :: Int -> Command -> Command+setResultOffset off q@Search{}+    = q { icOffsetSR = off }+setResultOffset _ q+    = q++-- | configure search command: set the list of attributes of the document decription+-- to be included in the result list+--+-- example: @setSelectedFields ["title", "date"]@ restricts the documents+-- attributes to these to fields++setSelectedFields :: [Text] -> Command -> Command+setSelectedFields fs q@Search{}+    = q { icFields = Just fs }++setSelectedFields _ q+    = q++-- |  configure search command: include document weight in result list++setWeightIncluded :: Command -> Command+setWeightIncluded q@Search{}+    = q { icWeight = True }+setWeightIncluded q+    = q+++-- | create InsertContext Commands by a list of Insert Commands+-- These contexts are not optimized and shoudn't be used in production code.+createContextCommands :: [ApiDocument] -> Command+createContextCommands docs = cmdSequence cmds+  where+    names = nub $ docs >>= (LM.keys . adIndex)+    cmds = (\name -> cmdInsertContext name mkSchema) <$> names+-- ------------------------------------------------------------++-- | build an api document with an uri as key and a description+-- map as contents++mkApiDoc :: URI -> ApiDocument+mkApiDoc u+    = ApiDocument+      { adUri   = u+      , adIndex = emptyApiDocIndexMap+      , adDescr = emptyApiDocDescr+      , adWght  = noScore+      }++-- | add an index map containing the text parts to be indexed++setDescription :: Description -> ApiDocument -> ApiDocument+setDescription descr d+    = d { adDescr = descr }++getDescription :: ApiDocument -> Description+getDescription = adDescr++lookupDescription :: FromJSON v => Text -> ApiDocument -> Maybe v+lookupDescription k+    = DD.lookup k . adDescr++lookupDescriptionText :: Text -> ApiDocument -> Text+lookupDescriptionText k+    = DD.lookupText k . adDescr++addDescription :: ToJSON v => Text -> v -> ApiDocument -> ApiDocument+addDescription k v+    = changeDescription $ DD.insert k v++remDescription :: Text -> ApiDocument -> ApiDocument+remDescription k+    = changeDescription $ DD.delete k++changeDescription :: (Description -> Description) -> ApiDocument -> ApiDocument+changeDescription f a = a { adDescr = f . adDescr $ a }++-- | add an index map containing the text parts to be indexed++setIndex :: IndexMap -> ApiDocument -> ApiDocument+setIndex im d+    = d { adIndex = im }++addToIndex :: Context -> Content -> ApiDocument -> ApiDocument+addToIndex cx ct d+    | T.null ct = d+    | otherwise = changeIndex (SM.insert cx ct) d++getFromIndex :: Context -> ApiDocument -> Text+getFromIndex cx d+    = maybe "" id . SM.lookup cx . adIndex $ d++changeIndex :: (IndexMap -> IndexMap) -> ApiDocument -> ApiDocument+changeIndex f a = a { adIndex = f $ adIndex a }++-- | add a document weight++setDocWeight :: Score -> ApiDocument -> ApiDocument+setDocWeight w d+    = d { adWght = w }++-- | wrapper for building an ApiDocument by lists+listToApiDoc+  :: Text -- ^ The uri+  -> [(Text, Text)] -- ^ The index+  -> [(Text, Text)] -- ^ The description+  -> ApiDocument+listToApiDoc uri k v = setDescription (mkDescription v) $ setIndex (LM.fromList k) $ mkApiDoc $ uri+++-- ------------------------------------------------------------+-- document description++-- build a document description from a list of key-value pairs with+-- simple text values++mkDescription :: [(Text, Text)] -> Description+mkDescription+    = DD.fromList . filter (not . T.null . snd)++mapToDescr :: LM.Map Text Text -> DD.DocDesc+mapToDescr src = mkDescription $ LM.toList src++-- insert a key-value pair with an arbitrary value into+-- a document description++insDescription :: ToJSON v => Text -> v -> Description -> Description+insDescription+    = DD.insert++emptyDescription :: Description+emptyDescription = DD.empty++fromDescription :: Description ->  [(Text, Value)]+fromDescription = DD.toList++insertCmdsToDocuments :: Command -> [ApiDocument]+insertCmdsToDocuments (Insert d)    = [d]+insertCmdsToDocuments (Sequence cs) = cs >>= insertCmdsToDocuments+insertCmdsToDocuments _             = []++-- ------------------------------------------------------------+++++-- ------------------------------------------------------------+-- context schema construction++-- | the default schema: context type is text, no normalizers,+-- weigth is 1.0, context is always searched by queries without context spec++mkSchema :: ContextSchema+mkSchema = def++-- | prevent searching in context, when not explicitly set in query++setCxNoDefault :: ContextSchema -> ContextSchema+setCxNoDefault sc+    = sc { cxDefault = False }++-- | set the regex for splitting a text into words++setCxWeight :: Float -> ContextSchema -> ContextSchema+setCxWeight w sc+    = sc { cxWeight = mkScore w }++-- | set the regex for splitting a text into words++setCxRegEx :: RegEx -> ContextSchema -> ContextSchema+setCxRegEx re sc+    = sc { cxRegEx = Just re }++-- | add a text normalizer for transformation into uppercase++setCxUpperCase :: ContextSchema -> ContextSchema+setCxUpperCase sc+    = sc { cxNormalizer = cnUpperCase : cxNormalizer sc }++-- | add a text normalizer for transformation into lowercase++setCxLowerCase :: ContextSchema -> ContextSchema+setCxLowerCase sc+    = sc { cxNormalizer = cnLowerCase : cxNormalizer sc }++-- | add a text normalizer for transformation into lowercase++setCxZeroFill :: ContextSchema -> ContextSchema+setCxZeroFill sc+    = sc { cxNormalizer = cnZeroFill : cxNormalizer sc }++-- | set the type of a context to text++setCxText :: ContextSchema -> ContextSchema+setCxText sc+    = sc { cxType = ctText }++-- | set the type of a context to Int++setCxInt :: ContextSchema -> ContextSchema+setCxInt sc+    = sc { cxType = ctInt }++-- | set the type of a context to Date++setCxDate :: ContextSchema -> ContextSchema+setCxDate sc+    = sc { cxType = ctDate }++-- | set the type of a context to Int++setCxPosition :: ContextSchema -> ContextSchema+setCxPosition sc+    = sc { cxType = ctPosition }++-- ------------------------------------------------------------++completeQueries :: Query -> [Text] -> [Query]+completeQueries (QWord t _)         comps = (\c -> QWord t (c))    <$> comps+completeQueries (QFullWord t _)     comps = (\c -> QFullWord t (c))<$> comps+completeQueries (QPhrase t _)       comps = (\c -> QPhrase t (c))  <$> comps+completeQueries (QContext cxs q)    comps = (QContext cxs)              <$> (completeQueries q comps)+completeQueries (QBinary op q1 q2)  comps = (QBinary op q1)             <$> (completeQueries q2 comps)+completeQueries (QSeq    op qs)     comps = (QSeq op)                   <$> (completeLast qs)+  where+  completeLast [] = []+  completeLast [q] = sequence [completeQueries q comps]+  completeLast (q:qs') = (q :)  <$> completeLast qs'+completeQueries (QBoost w q)        comps = (QBoost w)                  <$> (completeQueries q comps)+completeQueries (QRange t1 t2)      _     = [QRange t1 t2] -- TODO++-- ------------------------------------------------------------++-- client output++-- | send command as JSON into a file+--+-- the JSON is pretty printed with aeson-pretty,+-- @""@ and @"-"@ are used for output to stdout++sendCmdToFile :: String -> Command -> IO ()+sendCmdToFile fn cmd+    = outputValue fn cmd++-- ------------------------------------------------------------
+ src/Hunt/Common.hs view
@@ -0,0 +1,39 @@+{- |+  Module     : Hunt.Index.Common+  License    : MIT++  Maintainer : Ulf Sauer+  Stability  : experimental+  Portability: none portable++  Common data types shared by all index types and a unified interface for+  all different index types. This module defines the common interfaces of+  indexes and their document tables as well as full-text caches.+-}+-- ----------------------------------------------------------------------------++module Hunt.Common+  (+    module Hunt.Common.BasicTypes+  , module Hunt.Common.DocId+  , module Hunt.Common.DocIdMap+  , module Hunt.Common.DocIdSet+  , module Hunt.Common.Document+  , module Hunt.Common.Occurrences+  , module Hunt.Common.Positions+  , module Hunt.Common.RawResult+  , module Hunt.Common.ApiDocument+  , module Hunt.Index.Schema+  )+where++import           Hunt.Common.ApiDocument (ApiDocument (..))+import           Hunt.Common.BasicTypes+import           Hunt.Common.DocId+import           Hunt.Common.DocIdMap    (DocIdMap)+import           Hunt.Common.DocIdSet    (DocIdSet)+import           Hunt.Common.Document    (Document (..))+import           Hunt.Common.Occurrences (Occurrences)+import           Hunt.Common.Positions   (Positions)+import           Hunt.Common.RawResult+import           Hunt.Index.Schema
+ src/Hunt/Common/ApiDocument.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE OverloadedStrings #-}++-- ----------------------------------------------------------------------------++{- |+  Document format for the interpreter and JSON API.+  It includes the document description, the index data and additional metadata.+-}++-- ----------------------------------------------------------------------------++module Hunt.Common.ApiDocument where++import           Control.Applicative+import           Control.DeepSeq+import           Control.Monad          (mzero)++import           Data.Aeson+import           Data.Binary            (Binary (..))+import           Data.Map.Strict        (Map ())+import qualified Data.Map.Strict        as M+import           Data.Text              (Text)+import qualified Data.Text              as T+import           Data.Text.Binary       ()++import           Hunt.Common.BasicTypes+import qualified Hunt.Common.DocDesc    as DD++import           Hunt.Utility.Log++-- ------------------------------------------------------------++-- | The document accepted by the interpreter and JSON API.++data ApiDocument  = ApiDocument+    { adUri   :: URI              -- ^ The unique identifier.+    , adIndex :: IndexMap         -- ^ The data to index according to schema associated with the context.+    , adDescr :: Description      -- ^ The document description (a simple key-value map).+    , adWght  :: Score            -- ^ An optional document boost, (internal default is @1.0@).+    }+    deriving (Show)++-- | Context map+type IndexMap = Map Context Content++-- | Multiple 'ApiDocument's.+type ApiDocuments = [ApiDocument]++-- | Text analysis function+type AnalyzerFunction = Text -> [(Position, Text)]++-- | Types of analyzer+data AnalyzerType = DefaultAnalyzer+                    deriving (Show)+++-- | Paginated result with an offset and chunk size.+data LimitedResult x = LimitedResult+    { lrResult :: [x] -- ^ The list with at most 'lrMax' elements.+    , lrOffset :: Int -- ^ The offset of the result.+    , lrMax    :: Int -- ^ The limit for the result.+    , lrCount  :: Int -- ^ The size of the complete result.+    }+    deriving (Show, Eq)++instance NFData x => NFData (LimitedResult x) where+  rnf (LimitedResult r o m c) = r `seq` o `seq` m `seq` c `seq` ()++-- ------------------------------------------------------------++-- | Create a paginated result with an offset and a chunk size.+--   The result also includes the size of the complete result.++mkLimitedResult :: Int -> Int -> [x] -> LimitedResult x+mkLimitedResult offset mx xs = LimitedResult+  { lrResult = ( if mx < 0+                 then id+                 else take mx+               ) . drop offset $ xs+  , lrOffset = offset+  , lrMax    = mx+  , lrCount  = length xs+  }+++-- | Empty index content.+emptyApiDocIndexMap :: IndexMap+emptyApiDocIndexMap = M.empty++-- | Empty 'Document' description.+emptyApiDocDescr :: Description+emptyApiDocDescr = DD.empty++-- | Empty 'ApiDocument'.+emptyApiDoc :: ApiDocument+emptyApiDoc = ApiDocument "" emptyApiDocIndexMap emptyApiDocDescr noScore++-- ------------------------------------------------------------++instance NFData ApiDocument where+  --default++-- ------------------------------------------------------------++instance Binary ApiDocument where+  put (ApiDocument a b c d)+      = put a >> put b >> put c >> put d+  get = ApiDocument <$> get <*> get <*> get <*> get++-- ------------------------------------------------------------++instance LogShow ApiDocument where+  logShow o = "ApiDocument {adUri = \"" ++ (T.unpack . adUri $ o) ++ "\", ..}"++-- ------------------------------------------------------------+-- JSON instances+-- ------------------------------------------------------------++instance (ToJSON x) => ToJSON (LimitedResult x) where+   toJSON (LimitedResult res offset mx cnt) = object+    [ "result" .= res+    , "offset" .= offset+    , "max"    .= mx+    , "count"  .= cnt+    ]++instance (FromJSON x) => FromJSON (LimitedResult x) where+  parseJSON (Object v) = do+    res    <- v .: "result"+    offset <- v .: "offset"+    mx     <- v .: "max"+    cnt    <- v .: "count"+    return $ LimitedResult res offset mx cnt+  parseJSON _ = mzero++instance FromJSON ApiDocument where+  parseJSON (Object o) = do+    parsedUri <- o    .: "uri"+    indexMap  <- o    .:? "index"       .!= emptyApiDocIndexMap+    descrMap  <- o    .:? "description" .!= emptyApiDocDescr+    weight    <- mkScore <$>+                 o    .:? "weight"      .!= 0.0+    return ApiDocument+      { adUri    = parsedUri+      , adIndex  = indexMap+      , adDescr  = descrMap+      , adWght   = weight+      }+  parseJSON _ = mzero++instance ToJSON ApiDocument where+  toJSON (ApiDocument u im dm wt)+      = object $+        ( maybe [] (\ x -> ["weight" .= x]) $ getScore wt )+        +++        ( if M.null im+          then []+          else ["index" .= im]+        )+        +++        ( if DD.null dm+          then []+          else ["description" .= dm]+        )+        +++        ["uri" .= u]++instance FromJSON AnalyzerType where+  parseJSON (String s) =+    case s of+      "default" -> return DefaultAnalyzer+      _         -> mzero+  parseJSON _ = mzero++instance ToJSON AnalyzerType where+  toJSON (DefaultAnalyzer) =+    "default"++-- ------------------------------------------------------------
+ src/Hunt/Common/BasicTypes.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}++-- ----------------------------------------------------------------------------++{- |+  Common types used within Hunt.+-}++-- ----------------------------------------------------------------------------++module Hunt.Common.BasicTypes+    ( module Hunt.Common.BasicTypes+    , Monoid(..)+    , (<>)+    )+where++import           Control.Applicative+import           Control.Monad       (mzero)+import           Control.DeepSeq++import           Data.Aeson+import           Data.Binary         hiding (Word)+import           Data.Map+import           Data.Monoid         (Monoid (..), (<>))+import           Data.Text++import           Hunt.Common.DocDesc (DocDesc)++import           Prelude             as P++-- ------------------------------------------------------------++-- | The URI describing the location of the original document.+type URI          = Text++-- | The description of a document is a generic key value map.+type Description  = DocDesc++-- | The title of a document.+type Title        = Text++-- | The content of a document.+type Content      = Text++-- | The position of a word in the document.+type Position     = Int++-- | The name of a context.+type Context      = Text++-- | A single word.+type Word         = Text++-- | Positions of Words for each context.+type Words        = Map Context WordList++-- | Positions of words in the document.+type WordList     = Map Word [Position]++-- | Text index+data TextSearchOp = Case | NoCase | PrefixCase | PrefixNoCase+  deriving (Eq, Show)++-- | Weight (for ranking).+type Weight       = Score++-- | Regular expression.+type RegEx        = Text++-- | The score of a hit (either a document hit or a word hit).+-- type Score        = Float++-- ------------------------------------------------------------++-- | Weight or score of a documents,+-- @0.0@ indicates: not set, so there is no need to work with Maybe's+--  wrapped in newtype to not mix up with Score's and Weight's in documents++newtype Score = SC {unScore :: Float}+    deriving (Eq, Ord, Num, Fractional, Show)++instance NFData Score where+  rnf (SC f) = f `seq` ()++noScore :: Score+noScore = SC 0.0++mkScore :: Float -> Score+mkScore x+    | x > 0.0   = SC x+    | otherwise = noScore++getScore :: Score -> Maybe Float+getScore (SC 0.0) = Nothing+getScore (SC x  ) = Just x++defScore :: Score+defScore = SC 1.0++toDefScore :: Score -> Score+toDefScore (SC 0.0) = defScore+toDefScore sc       = sc++fromDefScore :: Score -> Score+fromDefScore (SC 1.0) = noScore+fromDefScore sc       = sc++accScore :: [Score] -> Score+accScore [] = defScore+accScore xs = mkScore $ sum (P.map unScore xs) / fromIntegral (P.length xs)++-- the Monoid instance is used to accumulate scores+-- in query results, so tune it here when sum is not appropriate++instance Monoid Score where+    mempty = noScore+    mappend = (+)++-- ------------------------------------------------------------+-- JSON instances+-- ------------------------------------------------------------++instance FromJSON Score where+    parseJSON x = mkScore <$> parseJSON x++instance ToJSON Score where+    toJSON (SC x) = toJSON x++instance FromJSON TextSearchOp where+    parseJSON (String s)+        = case s of+            "case"         -> return Case+            "noCase"       -> return NoCase+            "prefixCase"   -> return PrefixCase+            "prefixNoCase" -> return PrefixNoCase+            _              -> mzero+    parseJSON _ = mzero++instance ToJSON TextSearchOp where+  toJSON o = case o of+    Case         -> "case"+    NoCase       -> "noCase"+    PrefixCase   -> "prefixCase"+    PrefixNoCase -> "prefixNoCase"++-- ------------------------------------------------------------+-- Binary instances+-- ------------------------------------------------------------++instance Binary Score where+    put (SC x) = put x+    get = SC <$> get++instance Binary TextSearchOp where+  put (Case)         = put (0 :: Word8)+  put (NoCase)       = put (1 :: Word8)+  put (PrefixCase)   = put (2 :: Word8)+  put (PrefixNoCase) = put (3 :: Word8)++  get = do+    t <- get :: Get Word8+    case t of+      0 -> return Case+      1 -> return NoCase+      2 -> return PrefixCase+      3 -> return PrefixNoCase+      _ -> fail "enum out of bounds: TextSearchOp"++-- ------------------------------------------------------------
+ src/Hunt/Common/DocDesc.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Hunt.Common.DocDesc+where++import           Prelude             hiding (lookup)++import           Control.Arrow       (second)+import           Control.DeepSeq+import           Control.Monad       (mzero)++import           Data.Aeson          (FromJSON (..), Object, Result (..),+                                      ToJSON (..), Value (..), decode, encode,+                                      fromJSON)+import           Data.Binary         (Binary (..))+import qualified Data.HashMap.Strict as HM+import           Data.Maybe          (fromMaybe)+import           Data.Text           (Text)+import           Data.Text.Binary    ()+import           Data.Typeable++-- ------------------------------------------------------------+-- {- the new DocDesc with JSON values as attributes++newtype DocDesc+  = DocDesc { unDesc :: Object }+  deriving (Eq, Show, NFData, Typeable)++-- | Smart constructor for document descriptions.++mkDocDesc :: Object -> DocDesc+mkDocDesc o+    = DocDesc $!! o++instance Binary DocDesc where+    put = put . encode . unDesc+    get = do bs <- get+             case decode bs of+               Nothing -> fail "DocDesc.get: error in decoding from JSON"+               Just x  -> return $! (mkDocDesc x)++instance ToJSON DocDesc where+    toJSON = Object . unDesc++instance FromJSON DocDesc where+    parseJSON (Object o) = return $! (mkDocDesc o)+    parseJSON _          = mzero++-- | The empty description.++empty :: DocDesc+empty = mkDocDesc HM.empty++-- | Check if document description is empty.++null :: DocDesc -> Bool+null (DocDesc m) = HM.null m++-- | Insert key value pair into description.++insert :: ToJSON v => Text -> v -> DocDesc -> DocDesc+insert k v (DocDesc m)+    = mkDocDesc $ HM.insert k (toJSON v) m++-- | Remove a key value pair++delete :: Text -> DocDesc -> DocDesc+delete k (DocDesc m)+    = mkDocDesc $ HM.delete k m++-- | Union of two descriptions.++union :: DocDesc -> DocDesc -> DocDesc+union (DocDesc m1) (DocDesc m2)+    = mkDocDesc $ HM.union m1 m2++-- | restrict a DocDesc map to a set of fields++restrict :: [Text] -> DocDesc -> DocDesc+restrict ks (DocDesc m)+    = mkDocDesc $ HM.filterWithKey sel m+      where+        sel k _v = k `elem` ks++deleteNull :: DocDesc -> DocDesc+deleteNull (DocDesc m)+    = mkDocDesc $ HM.filter notNull m+      where+        notNull Null = False+        notNull _    = True++lookupValue :: Text -> DocDesc -> Value+lookupValue k (DocDesc m)+    = fromMaybe Null $ HM.lookup k m++lookup :: FromJSON v => Text -> DocDesc -> Maybe v+lookup k d+    = toMaybe . fromJSON . lookupValue k $ d+    where+      toMaybe (Success v) = Just v+      toMaybe _              = Nothing++lookupText :: Text -> DocDesc -> Text+lookupText k d+    = fromMaybe "" . lookup k $ d++-- | Create a document description from as list++fromList :: ToJSON v => [(Text, v)] -> DocDesc+fromList l = mkDocDesc $ HM.fromList (map (second toJSON) l)++-- | Create a list from a document description.++toList :: DocDesc -> [(Text, Value)]+toList (DocDesc m) = HM.toList m++-- ------------------------------------------------------------
+ src/Hunt/Common/DocId.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE OverloadedStrings #-}++-- ----------------------------------------------------------------------------++{- |+  Module     : Hunt.Index.Common.DocId+  Copyright  : Copyright (C) 2014 Uwe Schmidt+  License    : MIT++  Maintainer : Uwe Schmidt (uwe@fh-wedel.de)++  The document identifier type DocId and the newtype DocId' with Show and ToJSOn instances+-}++-- ----------------------------------------------------------------------------++module Hunt.Common.DocId+where++import           Control.Applicative++import           Data.Aeson+import           Data.Binary          (Binary (..))+import qualified Data.Binary          as B+import           Data.Digest.Murmur64++-- ------------------------------------------------------------+{-+-- | The unique identifier of a document.+type DocId = Int++-- ------------------------------------------------------------++-- | Create the null-identifier.+mkNull :: DocId+mkNull = 0++-- | Create the first identifier.+mkFirst :: DocId+mkFirst = 1++-- | Create a 'DocId' from an 'Integer'.+fromInteger :: Integer -> DocId+fromInteger = fromIntegral++-- ------------------------------------------------------------++{-# INLINE mkNull #-}+{-# INLINE mkFirst #-}+{-# INLINE fromInteger #-}++-- -}+-- ------------------------------------------------------------++-- the wrapped DocId+-- currently only used for JSON debug output++newtype DocId = DocId {unDocId :: Int}+    deriving (Eq, Ord)++instance Show DocId where+    show = toHex . unDocId++instance Binary DocId where+    put = put . unDocId+    get = DocId <$> get++instance ToJSON DocId where+    toJSON (DocId i) = toJSON $ toHex i++mkDocId :: Binary a => a -> DocId+mkDocId = DocId . fromIntegral . asWord64 . hash64 . B.encode++toHex :: Int -> String+toHex !y = "0x" ++ toX 16 "" y+    where+      toX :: Int -> String -> Int -> String+      toX !0 !acc _ = acc+      toX !n !acc x = toX (n - 1) (d : acc) x'+          where+            (!x', !r) = x `divMod` 16+            !d | r < 10    = toEnum (fromEnum '0' + r)+               | otherwise = toEnum (fromEnum 'a' + r - 10)++fromHex :: String -> Maybe Int+fromHex i@('0' : 'x' : xs)+    | length xs == 16+      &&+      all (`elem` "0123456789abcdef") xs+        = Just . read $ i+    | otherwise+        = Nothing++fromHex _+    = Nothing++-- ------------------------------------------------------------
+ src/Hunt/Common/DocIdMap.hs view
@@ -0,0 +1,316 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}++-- ----------------------------------------------------------------------------++{- |+  Module     : Hunt.Index.Common.DocIdMap+  Copyright  : Copyright (C) 2012 Sebastian M. Schlatt, Timo B. Huebel, Uwe Schmidt+  License    : MIT+  Maintainer : Uwe Schmidt++  Efficient Map implementation for 'DocId's.+-}++-- ----------------------------------------------------------------------------++module Hunt.Common.DocIdMap+  ( DocIdMap(..)+  , empty+  , singleton+  , null+  , member+  , lookup+  , insert+  , delete+  , insertWith+  , size+  , sizeWithLimit+  , union+  , intersection+  , difference+  , diffWithSet+  , unionWith+  , intersectionWith+  , differenceWith+  , unionsWith+  , map+  , filter+  , filterWithKey+  , mapWithKey+  , traverseWithKey+  , foldr+  , foldrWithKey+  , foldl+  , fromList+  , fromDocIdSet+  , fromAscList+  , toList+  , keys+  , elems+  )+where++import           Prelude                    hiding (filter, foldl, foldr,+                                             lookup, map, null)+import qualified Prelude                    as P++import           Control.Applicative        (Applicative (..), (<$>))+import           Control.Arrow              (first)+import           Control.DeepSeq+import           Control.Monad              (foldM, mzero)++import           Data.Aeson+import           Data.Binary                (Binary (..))+import           Data.Foldable              hiding (fold, foldl, foldr, toList)+import qualified Data.HashMap.Strict        as HM+import qualified Data.IntMap.BinTree.Strict as IM+import qualified Data.List                  as L+import           Data.Monoid                (Monoid (..), (<>))+import qualified Data.Text                  as T+import           Data.Typeable++import           Hunt.Common.DocId+import           Hunt.Common.DocIdSet       (DocIdSet (..), toIntSet)++-- ------------------------------------------------------------++-- | An efficient Map implementation for 'DocId's.++newtype DocIdMap v+  = DIM { unDIM :: IM.IntMap v }+  deriving (Eq, Show, Foldable, {-Traversable,-} Functor, NFData, Typeable)++-- ------------------------------------------------------------++instance Monoid v => Monoid (DocIdMap v) where+    mempty  = DIM IM.empty+    mappend = unionWith (<>)++instance Binary v => Binary (DocIdMap v) where+  put = put . unDIM+  get = get >>= return . DIM++instance ToJSON v => ToJSON (DocIdMap v) where+  toJSON = object . L.map toJ . IM.toList . unDIM+    where+    toJ (k, v) = (T.pack . toHex $ k) .= toJSON v++instance FromJSON v => FromJSON (DocIdMap v) where+  parseJSON (Object o) = DIM <$> foldM parsePair IM.empty (HM.toList o)+    where+    parsePair res (k, v)+      = case fromHex . T.unpack $ k of+          Nothing -> mzero+          Just k' -> do+            v' <- parseJSON v+            return $ IM.insert k' v' res++  parseJSON _          = mzero++-- ------------------------------------------------------------++liftDIM                 :: (IM.IntMap v -> IM.IntMap r) ->+                           DocIdMap v -> DocIdMap r+liftDIM f               = DIM . f . unDIM++liftDIM2                :: (IM.IntMap v -> IM.IntMap w -> IM.IntMap x) ->+                           DocIdMap v -> DocIdMap w -> DocIdMap x+liftDIM2 f x y          = DIM $ f (unDIM x) (unDIM y)++-- | The empty map.+empty                   :: DocIdMap v+empty                   = DIM $ IM.empty++-- | A map with a single element.+singleton               :: DocId -> v -> DocIdMap v+singleton d v           = insert d v empty++-- | Is the map empty?+null                    :: DocIdMap v -> Bool+null                    = IM.null . unDIM++-- | Is the 'DocId' member of the map?+member                  :: DocId -> DocIdMap v -> Bool+member x                = IM.member (unDocId x) . unDIM++-- | Lookup the value at a 'DocId' in the map.++--   The function will return the corresponding value as @('Just' value)@,+--   or 'Nothing' if the 'DocId' isn't in the map.+lookup                  :: DocId -> DocIdMap v -> Maybe v+lookup x                = IM.lookup (unDocId x) . unDIM++-- | Insert a 'DocId' and value in the map.+--   If the 'DocId' is already present in the map, the associated value is replaced with the supplied+--   value. 'insert' is equivalent to 'insertWith' 'const'.+insert                  :: DocId -> v -> DocIdMap v -> DocIdMap v+insert x y              = liftDIM $ IM.insert (unDocId x) y++-- | Delete a 'DocId' and its value from the map.+--   When the 'DocId' is not a member of the map, the original map is returned.+delete                  :: DocId -> DocIdMap v -> DocIdMap v+delete x                = liftDIM $ IM.delete (unDocId x)++-- | Insert with a function, combining new value and old value.+--   @insertWith f docId value mp@ will insert the pair @(docId, value)@ into @mp@ if @docId@ does+--   not exist in the map. If the 'DocId' does exist, the function will insert the pair+--   @(docId, f new_value old_value)@.+insertWith              :: (v -> v -> v) -> DocId -> v -> DocIdMap v -> DocIdMap v+insertWith f x y        = liftDIM $ IM.insertWith f (unDocId x) y++-- | The number of elements in the map.+size                    :: DocIdMap v -> Int+size                    = IM.size . unDIM++-- | The number of elements limited up to a maximum+sizeWithLimit           :: Int -> DocIdMap v -> Maybe Int+sizeWithLimit limit     = IM.sizeWithLimit limit . unDIM++-- | The (left-biased) union of two maps.+--   It prefers the first map when duplicate 'DocId' are encountered,+--   i.e. @(union == unionWith const)@.+union                   :: DocIdMap v -> DocIdMap v -> DocIdMap v+union                   = liftDIM2 $ IM.union++-- | The (left-biased) intersection of two maps (based on 'DocId's).+intersection            :: DocIdMap v -> DocIdMap v -> DocIdMap v+intersection            = liftDIM2 $ IM.intersection++-- | Difference between two maps (based on 'DocId's).+difference              :: DocIdMap v -> DocIdMap w -> DocIdMap v+difference              = liftDIM2 $ IM.difference++-- | Difference between the map and a set of 'DocId's.+diffWithSet             :: DocIdMap v -> DocIdSet -> DocIdMap v+diffWithSet m s         = m `difference` (DIM $ IM.fromSet (const ()) (unDIS s))++-- | The union with a combining function.+unionWith               :: (v -> v -> v) -> DocIdMap v -> DocIdMap v -> DocIdMap v+unionWith f             = liftDIM2 $ IM.unionWith f++-- | The intersection with a combining function.+intersectionWith        :: (v -> v -> v) -> DocIdMap v -> DocIdMap v -> DocIdMap v+intersectionWith f      = liftDIM2 $ IM.intersectionWith f++-- | Difference with a combining function.+differenceWith          :: (v -> v -> Maybe v) -> DocIdMap v -> DocIdMap v -> DocIdMap v+differenceWith f        = liftDIM2 $ IM.differenceWith f++-- | The union of a list of maps, with a combining operation.+unionsWith              :: (v -> v -> v) -> [DocIdMap v] -> DocIdMap v+unionsWith f            = DIM . IM.unionsWith f . P.map unDIM++-- | Map a function over all values in the map.+map                     :: (v -> r) -> DocIdMap v -> DocIdMap r+map f                   = liftDIM $ IM.map f++-- | Map a function over all values in the map.+mapWithKey              :: (DocId -> v -> r) -> DocIdMap v -> DocIdMap r+mapWithKey f            = liftDIM $ IM.mapWithKey (f . DocId)++-- | Filter all values that satisfy some predicate.+filter                  :: (v -> Bool) -> DocIdMap v -> DocIdMap v+filter p                = liftDIM $ IM.filter p++-- | Filter all 'DocId's/values that satisfy some predicate.+filterWithKey           :: (DocId -> v -> Bool) -> DocIdMap v -> DocIdMap v+filterWithKey p         = liftDIM $ IM.filterWithKey (p . DocId)++-- | @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@+--   That is, behaves exactly like a regular 'traverse' except that the traversing+--   function also has access to the 'DocId' associated with a value.+--+--   > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])+--   > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')])           == Nothing+traverseWithKey         :: Applicative t => (DocId -> a -> t b) -> DocIdMap a -> t (DocIdMap b)+traverseWithKey f       = (pure DIM <*>) . IM.traverseWithKey (f . DocId) . unDIM++-- | Fold the values in the map using the given right-associative binary operator, such that+--   @'foldr' f z == 'Prelude.foldr' f z . 'elems'@.+--+-- For example,+--+-- > elems map = foldr (:) [] map+--+-- > let f a len = len + (length a)+-- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4+foldr                   :: (v -> b -> b) -> b -> DocIdMap v -> b+foldr f u               = IM.foldr f u . unDIM++-- | Fold the 'DocId's and values in the map using the given right-associative+-- binary operator, such that+-- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.+--+-- For example,+--+-- > keys map = foldrWithKey (\k x ks -> k:ks) [] map+--+-- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"+-- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"+foldrWithKey            :: (DocId -> v -> b -> b) -> b -> DocIdMap v -> b+foldrWithKey f u        = IM.foldrWithKey (f . DocId) u . unDIM++foldl                   :: (b -> v -> b) -> b -> DocIdMap v -> b+foldl f u               = IM.foldl f u . unDIM++-- | Create a map from a list of 'DocId'\/value pairs.+fromList                :: [(DocId, v)] -> DocIdMap v+fromList                = DIM . IM.fromList . L.map (first unDocId)++-- | Create a map from a set of 'DocId' values+fromDocIdSet            :: (Int -> v) -> DocIdSet -> DocIdMap v+fromDocIdSet f s        = DIM $ IM.fromSet f (toIntSet s)++-- | Build a map from a list of 'DocId'\/value pairs where the 'DocId's are in ascending order.+fromAscList             :: [(DocId, v)] -> DocIdMap v+fromAscList             = DIM . IM.fromAscList . L.map (first unDocId)++-- | Convert the map to a list of 'DocId'\/value pairs.+--   Subject to list fusion.+toList                  :: DocIdMap v -> [(DocId, v)]+toList                  = L.map (first DocId) . IM.toList . unDIM++-- | Return all 'DocId's of the map in ascending order.+--   Subject to list fusion.+keys                    :: DocIdMap v -> [DocId]+keys                    = L.map DocId . IM.keys . unDIM++-- | Return all elements of the map in the ascending order of their 'DocId's.+--   Subject to list fusion.+elems                   :: DocIdMap v -> [v]+elems                   = IM.elems . unDIM++-- ------------------------------------------------------------++{-# INLINE liftDIM #-}+{-# INLINE liftDIM2 #-}+{-# INLINE empty #-}+{-# INLINE singleton #-}+{-# INLINE null #-}+{-# INLINE member #-}+{-# INLINE lookup #-}+{-# INLINE insert #-}+{-# INLINE delete #-}+{-# INLINE insertWith #-}+{-# INLINE size #-}+{-# INLINE union #-}+{-# INLINE difference #-}+{-# INLINE unionWith #-}+{-# INLINE intersectionWith #-}+{-# INLINE differenceWith #-}+{-# INLINE unionsWith #-}+{-# INLINE map #-}+{-# INLINE filter #-}+{-# INLINE filterWithKey #-}+{-# INLINE mapWithKey #-}+{-# INLINE foldr #-}+{-# INLINE foldrWithKey #-}+{-# INLINE fromList #-}+{-# INLINE toList #-}+{-# INLINE keys #-}+{-# INLINE elems #-}++-- ------------------------------------------------------------
+ src/Hunt/Common/DocIdSet.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- ----------------------------------------------------------------------------++{- |+  Module     : Hunt.Index.Common.DocIdSet+  Copyright  : Copyright (C) 2014 Uwe Schmidt+  License    : MIT+  Maintainer : Uwe Schmidt++  Efficient Set implementation for 'DocId's.+-}++-- ----------------------------------------------------------------------------++module Hunt.Common.DocIdSet+  ( DocIdSet(..)+  , singleton+  , null+  , member+  , fromList+  , toIntSet+  , toList+  , difference+  , union+  , intersection+  )+where++import           Prelude           hiding (null)++import           Control.DeepSeq+import           Control.Monad     (mzero)++import           Data.Aeson+import qualified Data.IntSet       as S+import qualified Data.List         as L+import           Data.Monoid       (Monoid (..))+import           Data.Typeable+import           Data.Binary       (Binary (..))+import           Hunt.Common.DocId++-- ------------------------------------------------------------+--+-- the wrapped DocId set++newtype DocIdSet = DIS { unDIS :: S.IntSet }+    deriving (Eq, Show, NFData, Typeable)++instance Binary DocIdSet where+  put = put . unDIS+  get = get >>= return . DIS++instance Monoid DocIdSet where+    mempty+        = DIS S.empty+    mappend (DIS s1) (DIS s2)+        = DIS (S.union s1 s2)++instance ToJSON DocIdSet where+    toJSON = toJSON . L.map DocId . S.toList . unDIS++instance FromJSON DocIdSet where+    parseJSON x = do l <- parseJSON x+                     case fromL l of+                       Nothing -> mzero+                       Just s  -> return $ DIS s+        where+          fromL :: [String] -> Maybe S.IntSet+          fromL = L.foldr ins (Just S.empty)+              where+                ins _ Nothing   = Nothing+                ins xs (Just s) = case fromHex xs of+                                    Nothing -> Nothing+                                    Just i  -> Just $ S.insert i s++difference :: DocIdSet -> DocIdSet -> DocIdSet+difference (DIS s1) (DIS s2) = DIS $ S.difference s1 s2++union :: DocIdSet -> DocIdSet -> DocIdSet+union (DIS s1) (DIS s2) = DIS $ S.union s1 s2++intersection :: DocIdSet -> DocIdSet -> DocIdSet+intersection (DIS s1) (DIS s2) = DIS $ S.intersection s1 s2++fromList :: [DocId] -> DocIdSet+fromList = DIS . S.fromList . L.map unDocId++toList :: DocIdSet -> [DocId]+toList = L.map DocId . S.toList . unDIS++toIntSet :: DocIdSet -> S.IntSet+toIntSet = unDIS++singleton :: DocId -> DocIdSet+singleton = DIS . S.singleton . unDocId++null :: DocIdSet -> Bool+null = S.null . unDIS++member :: DocId -> DocIdSet -> Bool+member x s = unDocId x `S.member` unDIS s++-- ------------------------------------------------------------
+ src/Hunt/Common/Document.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++-- ----------------------------------------------------------------------------++{- |+  The document representation.++  This includes the++  * URI for identification,+  * the description for the data itself+  * the weight used in ranking and+  * optionally a score+-}++-- ----------------------------------------------------------------------------++module Hunt.Common.Document+where++import           Control.Applicative+import           Control.DeepSeq++import           Data.Aeson+import           Data.Binary             (Binary (..))+import           Data.Text               as T+import           Data.Text.Binary        ()++import           Hunt.Common.ApiDocument+import           Hunt.Common.BasicTypes+import qualified Hunt.Common.DocDesc     as DD+import           Hunt.Utility.Log++-- ------------------------------------------------------------++-- | The document representation.+data Document = Document+  { uri   :: ! URI         -- ^ Unique identifier of the document.+  , desc  :: ! Description -- ^ Description of the document (simple key-value store).+  , wght  :: ! Score       -- ^ Weight used in ranking (default @1.0@).+  }+  deriving (Show, Eq)++emptyDocument :: Document+emptyDocument = Document "" DD.empty defScore++-- ------------------------------------------------------------+-- JSON instances implemented with ApiDocument+-- ------------------------------------------------------------++toApiDocument :: Document -> ApiDocument+toApiDocument (Document u d w)+    = ApiDocument u emptyApiDocIndexMap d (fromDefScore w)++fromApiDocument :: ApiDocument -> Document+fromApiDocument (ApiDocument u _ix d w)+    = Document u d (toDefScore w)++instance ToJSON Document where+    toJSON = toJSON . toApiDocument++instance FromJSON Document where+    parseJSON o = fromApiDocument <$> parseJSON o++-- ------------------------------------------------------------++instance Binary Document where+  put (Document u d w) = put u >> put d >> put w+  get = Document <$> get <*> get <*> get++instance NFData Document where+  rnf (Document t d _w) = rnf t `seq` rnf d++-- ------------------------------------------------------------++-- | Simple bijection between @e@ and 'Document' for compression.+class (NFData e) => DocumentWrapper e where+  -- | Get the document.+  unwrap :: e -> Document+  -- | Create e from document.+  wrap   :: Document -> e+  -- | Update the wrapped document.+  -- @update f = wrap . f . unwrap@.+  update :: (Document -> Document) -> e -> e+  update f = wrap . f . unwrap++instance DocumentWrapper Document where+  unwrap = id+  wrap   = id++-- ------------------------------------------------------------++instance LogShow Document where+  logShow o = "Document {uri = \"" ++ (T.unpack . uri $ o) ++ "\", ..}"++-- ------------------------------------------------------------
+ src/Hunt/Common/IntermediateValue.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances    #-}++module Hunt.Common.IntermediateValue where++import           Control.Arrow           (second)+import           Control.DeepSeq++import           Data.Aeson+import           Data.Binary             (Binary)+import qualified Data.List               as L++import           Hunt.Common.Occurrences (Occurrences)+import qualified Hunt.Common.Occurrences as Occ+import           Hunt.Common.DocIdSet    (DocIdSet (..))+import qualified Hunt.Common.DocIdSet    as DS+import qualified Hunt.Common.DocIdMap    as DM++-- This type represents the interface for a value to the engine+-- To have an easy first implementaton the intermediate is+-- basically the same as Occurrences, but that can be adjusted later+newtype IntermediateValue = IntermediateValue+  { unIntermediate :: Occurrences+  }+  deriving (Show, Eq)++mkIntermediateValue :: Occurrences -> IntermediateValue+mkIntermediateValue o = IntermediateValue $! o++instance NFData IntermediateValue where+  rnf (IntermediateValue occ) = rnf occ++instance ToJSON IntermediateValue where+  toJSON x = toJSON (fromIntermediate x :: Occurrences)++fromIntermediates :: IndexValue u => [(x, IntermediateValue)] -> [(x, u)]+fromIntermediates xs = L.map (second fromIntermediate) xs++fromScoredIntermediates :: IndexValue u => [(x, (s, IntermediateValue))] -> [(x, (s,u))]+fromScoredIntermediates xs = L.map (\(x,u) -> (x, second fromIntermediate $ u)) xs++toIntermediates :: IndexValue u => [(x,u)] -> [(x, IntermediateValue)]+toIntermediates xs = L.map (second toIntermediate) xs++class (Binary x, NFData x) => IndexValue x where+  toIntermediate   :: x -> IntermediateValue+  fromIntermediate :: IntermediateValue -> x+  mergeValues      :: x -> x -> x+  diffValues       :: DocIdSet -> x -> Maybe x++instance IndexValue Occurrences where+  toIntermediate   x = mkIntermediateValue x+  fromIntermediate x = unIntermediate $! x+  mergeValues      = Occ.merge+  diffValues s m   = let z = Occ.diffWithSet m s in+                     if Occ.null z then Nothing else Just z++mapToSet :: Occurrences -> DocIdSet+mapToSet = DS.fromList . DM.keys++instance IndexValue DocIdSet where+  toIntermediate     = mkIntermediateValue . Occ.fromDocIdSet+  fromIntermediate   = mapToSet . fromIntermediate+  mergeValues        = DS.union+  diffValues s1 s2   = let r = DS.difference s2 s1 in+                       if DS.null r then Nothing else Just r
+ src/Hunt/Common/Occurrences.hs view
@@ -0,0 +1,118 @@+-- ----------------------------------------------------------------------------++{- |+  Module     : Hunt.Common.Occurrences+  Copyright  : Copyright (C) 2011 Sebastian M. Schlatt, Timo B. Huebel, Uwe Schmidt+  License    : MIT++  Maintainer : Timo B. Huebel (tbh@holumbus.org)+  Stability  : experimental+  Portability: none portable++  Occurrences of words within the index.+  A word occurs in document at specific locations.+-}++-- ----------------------------------------------------------------------------++module Hunt.Common.Occurrences+where++import           Prelude                hiding (subtract)++import           Hunt.Common.BasicTypes+import           Hunt.Common.DocId+import           Hunt.Common.DocIdMap   (DocIdMap)+import           Hunt.Common.DocIdSet   (DocIdSet)+import qualified Hunt.Common.DocIdMap   as DM+import           Hunt.Common.Positions  (Positions)+import qualified Hunt.Common.Positions  as Pos++-- ------------------------------------------------------------++-- | The occurrences of words in documents.+--   A mapping from document ids to the positions in the document.+type Occurrences        = DocIdMap Positions++-- ------------------------------------------------------------++-- | Create an empty set of positions.+empty                   :: Occurrences+empty                   = DM.empty++-- | Create Occurrences from a 'DocIdSet'+--   Since the 'DocIdSet' contains no position information, we+--   assume position one for each 'DocId'+fromDocIdSet            :: DocIdSet -> Occurrences+fromDocIdSet s          = DM.fromDocIdSet (\_ -> Pos.singleton 1) s++-- | Create a single dcid set with a single position.+singleton               :: DocId -> Position -> Occurrences+singleton d p           = singleton' d [p]++-- | Create a single dcid set with a set of.+singleton'              :: DocId -> [Position] -> Occurrences+singleton' d ps         = DM.insert d (Pos.fromList ps) DM.empty++-- | Test on empty set of positions.+null                    :: Occurrences -> Bool+null                    = DM.null++-- | Determine the number of positions in a set of occurrences.+size                    :: Occurrences -> Int+size                    = DM.foldr ((+) . Pos.size) 0++-- | Add a position to occurrences.+insert                  :: DocId -> Position -> Occurrences -> Occurrences+insert d p              = DM.insertWith Pos.union d (Pos.singleton p)++-- | Add multiple positions to occurrences+insert'                 :: DocId -> Positions -> Occurrences -> Occurrences+insert' d ps occs       = Pos.foldr (insert d) occs ps++-- | Remove a position from occurrences.+deleteOccurrence        :: DocId -> Position -> Occurrences -> Occurrences+deleteOccurrence d p    = subtract (DM.singleton d (Pos.singleton p))++-- | Delete a document (by 'DocId') from occurrences.+delete                  :: DocId -> Occurrences -> Occurrences+delete                  = DM.delete++-- | Changes the DocIDs of the occurrences.+update                  :: (DocId -> DocId) -> Occurrences -> Occurrences+update f                = DM.foldrWithKey+                          (\ d ps res -> DM.insertWith Pos.union (f d) ps res) empty++-- | Merge two occurrences.+merge                   :: Occurrences -> Occurrences -> Occurrences+merge                   = DM.unionWith Pos.union++-- | Merge occurrences+merges                  :: [Occurrences] -> Occurrences+merges                  = DM.unionsWith Pos.union++-- | Difference of occurrences.+difference              :: Occurrences -> Occurrences -> Occurrences+difference              = DM.difference++-- | Remove Set of DocIds from Occurrences+diffWithSet             :: Occurrences -> DocIdSet -> Occurrences+diffWithSet             = DM.diffWithSet++-- | Subtract occurrences from some other occurrences.+subtract                :: Occurrences -> Occurrences -> Occurrences+subtract                = DM.differenceWith subtractPositions+  where+  subtractPositions p1 p2+    = if Pos.null diffPos+        then Nothing+        else Just diffPos+    where+    diffPos = Pos.difference p1 p2++intersectOccurrences    :: (Positions -> Positions -> Positions) ->+                           Occurrences -> Occurrences -> Occurrences+intersectOccurrences pf os1 os2+    = DM.filter (not . Pos.null) $ DM.intersectionWith pf os1 os2++-- ------------------------------------------------------------
+ src/Hunt/Common/Positions.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- ----------------------------------------------------------------------------++{- |+  Positions within document.+-}++-- ----------------------------------------------------------------------------++module Hunt.Common.Positions where++import           Control.Applicative    ((<$>))+import           Control.DeepSeq++import           Data.Aeson+import           Data.Binary            as B+import qualified Data.IntSet            as IS+import           Data.IntSet.Cache      as IS+import           Data.Maybe             (fromMaybe)+import           Data.Monoid            ()+import           Data.Typeable++import           Hunt.Common.BasicTypes++-- ------------------------------------------------------------++-- | The positions of the word in the document.++newtype Positions+    = PS {unPS :: IS.IntSet}+      deriving (Eq, Ord, Read, Show, Typeable, NFData, Monoid)++-- ------------------------------------------------------------++instance B.Binary Positions where+    put = B.put . toAscList+    get = fromList <$> B.get++instance ToJSON Positions where+    toJSON = toJSON . unPS++-- ------------------------------------------------------------++-- | Empty positions.+empty                :: Positions+empty                = PS IS.empty++-- | Positions with one element.+singleton            :: Position -> Positions+singleton            = PS . IS.cacheAt+--singleton            = PS . IS.singleton++-- | Test whether it is the empty positions.+null                 :: Positions -> Bool+null                 = IS.null . unPS++-- | Whether the 'Position' is part of 'Positions'.+member               :: Position -> Positions -> Bool+member p             = IS.member p . unPS++-- | Converts 'Positions' to a list of 'Position's in ascending order.+toAscList            :: Positions -> [Position]+toAscList            = IS.toAscList . unPS++-- | Constructs Positions from a list of 'Position's.+fromList             :: [Position] -> Positions+fromList             = PS . IS.unions . map IS.cacheAt+--fromList             = PS . IS.fromList++-- | Number of 'Position's.+size                 :: Positions -> Int+size                 = IS.size . unPS++-- | The union of two 'Positions'.+union                :: Positions -> Positions -> Positions+union s1 s2          = PS $ (unPS s1) `IS.union` (unPS s2)++-- | The union of two 'Positions'.+intersection         :: Positions -> Positions -> Positions+intersection s1 s2   = PS $ (unPS s1) `IS.intersection` (unPS s2)++-- | The union of two 'Positions'.+difference           :: Positions -> Positions -> Positions+difference s1 s2     = PS $ (unPS s1) `IS.difference` (unPS s2)++-- | A fold over Positions+foldr                :: (Position -> r -> r) -> r -> Positions -> r+foldr op e           = IS.foldr op e . unPS++-- | intersection with a "shifted" 2. set with elements decremented by a displacement @d@+-- before the element test+--+-- useful when searching for sequences of words (phrases)++intersectionWithDispl :: Int -> Positions -> Positions -> Positions+intersectionWithDispl d (PS s1) (PS s2)+    = PS $ IS.filter member' s1+      where+        member' i = (i + d) `IS.member` s2++-- | intersction with "fuzzy" element test. All elements @e1@ for which an element @e2@ in @s2@+-- is found with @e2 - e1 `elem` [lb..ub]@ remain in set @s1@.+--+-- Useful for context search with sequences of words.+-- This generatizes 'intersectionWithDispl'+--+-- Law: @intersectionWithIntervall d d == intersectionWithDispl d@++intersectionWithIntervall :: Int -> Int -> Positions -> Positions -> Positions+intersectionWithIntervall lb ub (PS s1) (PS s2)+    = PS $ IS.filter member' s1+    where+      member' i = minElem <= i + ub+          where+            (_ls, gt) = IS.split  (i + lb - 1) s2+            minElem   = fromMaybe (i + ub + 1) $ fst <$> IS.minView gt++-- ------------------------------------------------------------
+ src/Hunt/Common/RawResult.hs view
@@ -0,0 +1,52 @@+-- ----------------------------------------------------------------------------++{- |+  Module     : Hunt.Index.Common.RawResult+  Copyright  : Copyright (C) 2011 Sebastian M. Schlatt, Timo B. Huebel, Uwe Schmidt+  License    : MIT++  Maintainer : Timo B. Huebel (tbh@holumbus.org)+  Stability  : experimental+  Portability: none portable++  The raw result of index queries.+-}++-- ----------------------------------------------------------------------------++module Hunt.Common.RawResult+where++import           Data.Map                (Map)+import qualified Data.Map                as M++import           Hunt.Common.BasicTypes+import           Hunt.Common.DocIdMap    (DocIdMap)+import qualified Hunt.Common.DocIdMap    as DM+import           Hunt.Common.Occurrences+import           Hunt.Common.Positions++-- ------------------------------------------------------------++-- | The raw result returned when searching the index.+type RawResult = [(Word, Occurrences)]++type RawScoredResult = [(Word, (Score, Occurrences))]++-- ------------------------------------------------------------++-- | Transform the raw result into a tree structure ordered by word.+resultByWord :: Context -> RawResult -> Map Word (Map Context Occurrences)+resultByWord c+  = M.fromList . map (\ (w, o) -> (w, M.singleton c o))++-- | Transform the raw result into a tree structure ordered by document.+resultByDocument  :: Context -> RawResult -> DocIdMap (Map Context (Map Word Positions))+resultByDocument c os+  = DM.map transform $+        DM.unionsWith (flip $ (:) . head) (map insertWords os)+  where+  insertWords (w, o) = DM.map (\p -> [(w, p)]) o+  transform w        = M.singleton c (M.fromList w)++-- ------------------------------------------------------------
+ src/Hunt/ContextIndex.hs view
@@ -0,0 +1,483 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Rank2Types            #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++-- ----------------------------------------------------------------------------+{- |+  The context index introduces contexts and combines the index, document table and schema.+-}+-- ----------------------------------------------------------------------------++module Hunt.ContextIndex+  (+    -- * Construction+    empty++    -- * Contexts and Schema+  , insertContext+  , deleteContext+  , foreachContext+  , contexts+  , contextsM+  , hasContext+  , hasContextM++    -- * Queries+  , lookupRangeCx+  , lookupAllWithCx+  , searchWithCx+  , searchWithCxsNormalized+  , searchWithCxSc+  , lookupRangeCxSc++    -- * Insert\/Delete Documents+  , insertList+                                 -- XXX: these functions should be internal+                                 -- we export them to be able to test them+                                 -- is there a bedder approach to achieve this?+  , createDocTableFromPartition  -- only used in tests+  , unionDocTables               -- only used in tests+  , modifyWithDescription+  , delete+  , deleteDocsByURI+  , decodeCxIx+  , member++    -- * Types+  , ContextIndex (..)+  , ContextMap (..)+  , IndexRep+  , mkContextMap+  , mapToSchema+  )+where+{-+import           Debug.Trace                   (traceShow)+-- -}+import           Prelude+import qualified Prelude                       as P++import           Control.Applicative           (Applicative, (<$>), (<*>))+import           Control.Arrow+import           Control.Monad+import qualified Control.Monad.Parallel        as Par++import           Data.Binary                   (Binary (..))+import           Data.Binary.Get+import           Data.ByteString.Lazy          (ByteString)+import           Data.Map                      (Map)+import qualified Data.Map                      as M+import           Data.Maybe+import           Data.Set                      (Set)+import qualified Data.Set                      as S+import           Data.Text                     (Text)++import           Hunt.Common+import qualified Hunt.Common.DocDesc           as DocDesc+import qualified Hunt.Common.DocIdSet          as DS+import qualified Hunt.Common.Document          as Doc+import           Hunt.Common.IntermediateValue+import qualified Hunt.Common.Occurrences       as Occ++import           Hunt.DocTable                 (DocTable)+import qualified Hunt.DocTable                 as Dt+import qualified Hunt.Index                    as Ix+import           Hunt.Index.IndexImpl          (IndexImpl)+import qualified Hunt.Index.IndexImpl          as Impl+import           Hunt.Utility++-- ------------------------------------------------------------++-- | Context index introduces contexts and combines the major components of Hunt.++data ContextIndex dt = ContextIndex+  { ciIndex :: !ContextMap -- ^ Indexes associated to contexts.+  , ciDocs  :: !dt         -- ^ Document table.+  }++empty :: DocTable dt => ContextIndex dt+empty = ContextIndex emptyContextMap Dt.empty++-- | Contexts with associated heterogeneous index implementations.++type IndexRep = (ContextSchema, Impl.IndexImpl)++newtype ContextMap+  = ContextMap { cxMap :: Map Context IndexRep }+  deriving (Show)++-- | Empty context map.+emptyContextMap :: ContextMap+emptyContextMap = mkContextMap $ M.empty+++-- | Strict smart constructor for the 'ContextMap'.++mkContextMap :: Map Context IndexRep -> ContextMap+mkContextMap x = ContextMap $! x++-- | Get 'Schema' from 'ContextMap'+mapToSchema :: ContextMap -> Schema+mapToSchema (ContextMap m) = M.map fst m++-- ------------------------------------------------------------+-- Binary / Serialization+-- ------------------------------------------------------------++getContextMap :: [IndexImpl] -> Get ContextMap+getContextMap ts+  = do+    impls <- Impl.gets' ts+    s     <- get+    return . mkContextMap . M.fromDistinctAscList $ map (mergeGets s) impls+    where+      mergeGets s (c, i) = (c, (getS c s, i))+      getS c s = fromMaybe (error "deserializating failed: context schema is missing")+               $ lookup c s++instance Binary ContextMap where+  put = put . cxMap+  get = get >>= return . mkContextMap+++-- | Deserialize a 'ContextIndex' with the list of available index implementations and a+--   map of available 'ContextSchema'.+--+--   /Note/: The serialized index implementations have to  be in the list of available types,+--           otherwise this will fail. The serialized schemas have to be in the list of+--           available 'ContextSchema', otherwise this will fail as well.++decodeCxIx :: (Binary dt, DocTable dt) => [IndexImpl] -> ByteString -> ContextIndex dt+decodeCxIx ts = runGet (get' ts)++get' :: Binary dt => [IndexImpl] -> Get (ContextIndex dt)+get' ts = ContextIndex <$> (getContextMap ts) <*> get++instance Binary dt => Binary (ContextIndex dt) where+  get = error "existential types cannot be deserialized this way. Use special get' functions"+  put (ContextIndex (ContextMap a) b)+    = put (M.map snd a) >>  -- convert to 'IndexImpl' and serialize+      put (M.map fst a) >>  -- convert to 'Schema' and serialize+      put b                 -- put 'DocTable'++-- ------------------------------------------------------------++{-+-- | Insert a Document and Words.+--+--   /Note/: For multiple inserts, use the more efficient 'insertList'.+insert :: (Par.MonadParallel m, Applicative m, DocTable dt)+       => Dt.DValue dt -> Words -> ContextIndex dt -> m (ContextIndex dt)+insert doc wrds ix = insertList [(doc,wrds)] ix+-}++--   This is more efficient than using fold and with 'insert'.+-- | Insert multiple documents and words.++insertList :: (Par.MonadParallel m, Applicative m, DocTable dt) =>+              [(Dt.DValue dt, Words)] ->+              ContextIndex dt -> m (ContextIndex dt)++insertList docAndWords (ContextIndex ix docTable)+    = do -- insert to doctable and generate docId+         tablesAndWords <- Par.mapM createDocTableFromPartition+                         $ partitionListByLength 20 docAndWords+         -- union doctables and docid-words pairs+         (newDt, docIdsAndWords) <- unionDocTables tablesAndWords docTable+         -- insert words to index+         newIx <- batchAddWordsM docIdsAndWords ix+         return $! ContextIndex newIx newDt++-- takes list of documents with wordlist. creates new 'DocTable' and+-- inserts each document of the list into it.+createDocTableFromPartition :: (Par.MonadParallel m, DocTable dt) =>+                               [(Dt.DValue dt, Words)] -> m (dt, [(DocId, Words)])+createDocTableFromPartition ds+    = foldM toDocTable (Dt.empty, []) ds+    where+      toDocTable (dt, resIdsAndWords) (doc, ws)+        = do (dId, dt') <- Dt.insert doc dt+             return (dt', (dId, ws):resIdsAndWords)++-- takes list of doctables with lists of docid-words pairs attached+-- unions the doctables to one big doctable and concats the docid-words+-- pairs to one list+unionDocTables :: (DocTable dt, Par.MonadParallel m) =>+                  [(dt, [(DocId, Words)])] -> dt -> m (dt, [(DocId, Words)])+unionDocTables tablesAndWords oldDt+    = do step <- Par.mapM unionDtsAndWords $ mkPairs tablesAndWords+         case step of+                 []      -> return (Dt.empty, [])+                 [(d,w)] -> do n <- Dt.union oldDt d+                               return (n, w)+                 xs      -> unionDocTables xs oldDt+    where+      unionDtsAndWords ((dt1, ws1), (dt2, ws2))+        = do dt <- Dt.union dt1 dt2+             return (dt, ws1 ++ ws2)++      mkPairs []       = []+      mkPairs (a:[])   = [(a,(Dt.empty,[]))]+      mkPairs (a:b:xs) = (a,b):mkPairs xs++{-+-- XXX: this should not work well atm+-- | Modify documents and index data.++modify :: (Par.MonadParallel m, Applicative m, DocTable dt)+       => (Dt.DValue dt -> m (Dt.DValue dt))+       -> Words -> DocId -> ContextIndex dt -> m (ContextIndex dt)+modify f wrds dId (ContextIndex ii dt s) = do+  newDocTable <- Dt.adjust f dId dt+  newIndex    <- addWordsM wrds dId ii+  return $ ContextIndex newIndex newDocTable s+-- -}++-- | Delete a set of documents by 'URI'.+deleteDocsByURI :: (Par.MonadParallel m, Applicative m, DocTable dt)+                => Set URI -> ContextIndex dt -> m (ContextIndex dt)+deleteDocsByURI us ixx@(ContextIndex _ix dt) = do+  docIds <- liftM (DS.fromList . catMaybes) . mapM (flip Dt.lookupByURI dt) . S.toList $ us+  delete docIds ixx+++-- | Delete a set of documents by 'DocId'.+delete :: (Par.MonadParallel m, Applicative m, DocTable dt)+       => DocIdSet -> ContextIndex dt -> m (ContextIndex dt)+delete dIds cix@(ContextIndex ix dt)+    | DS.null dIds+        = return cix+    | otherwise+        = do newIx <- delete' dIds ix+             newDt <- Dt.difference dIds dt+             return $ ContextIndex newIx newDt+++-- | Is the document part of the index?+member :: (Monad m, Applicative m, DocTable dt)+       => URI -> ContextIndex dt -> m Bool+member u (ContextIndex _ii dt) = do+  mem <- Dt.lookupByURI u dt+  return $ isJust mem++-- ------------------------------------------------------------++-- | Modify the description of a document and add words+--   (occurrences for that document) to the index.++modifyWithDescription :: (Par.MonadParallel m, Applicative m, DocTable dt) =>+                         Score -> Description -> Words -> DocId -> ContextIndex dt ->+                         m (ContextIndex dt)+modifyWithDescription weight descr wrds dId (ContextIndex ii dt)+    = do newDocTable <- Dt.adjust mergeDescr dId dt+         newIndex    <- batchAddWordsM [(dId,wrds)] ii+         return $ ContextIndex newIndex newDocTable+    where+      -- M.union is left-biased+      -- flip to use new values for existing keys+      -- no flip to keep old values+      --+      -- Null values in new descr will remove associated attributes+      mergeDescr+          = return . Doc.update (updateWeight . updateDescr)+          where+            updateWeight d+                | weight == noScore = d+                | otherwise         = d {wght = weight}++            updateDescr d           = -- trc "updateDescr res=" $+                                      d {desc = DocDesc.deleteNull $+                                                flip DocDesc.union d' descr'+                                        }+                                      where+                                        d'     = -- trc "updateDescr old=" $+                                                 desc d+                                        descr' = -- trc "updateDescr new=" $+                                                 descr++-- trc :: Show a => String -> a -> a+-- trc msg x = traceShow (msg, x) x++-- ------------------------------------------------------------+-- Helper+-- ------------------------------------------------------------++-- | Adds words associated to a document to the index.+--++-- | Add words for a document to the 'Index'.+--+--   /Note/: Adds words to /existing/ 'Context's.++batchAddWordsM :: (Functor m, Par.MonadParallel m) =>+                  [(DocId, Words)] -> ContextMap -> m ContextMap+batchAddWordsM [] ix+    = return ix++batchAddWordsM vs (ContextMap m)+    = mkContextMap <$>+      mapWithKeyMP ( \cx (s, impl) -> do i <- foldinsertList cx impl+                                         return (s, i)+                   ) m+    where+      foldinsertList :: (Functor m, Monad m) =>+                        Context -> IndexImpl -> m IndexImpl+      foldinsertList cx (Impl.IndexImpl impl)+          = Impl.mkIndex <$>+            Ix.insertListM (contentForCx cx vs) impl++-- | Computes the words and occurrences out of a list for one context++contentForCx :: Context -> [(DocId, Words)] -> [(Word, IntermediateValue)]+contentForCx cx vs+    = concatMap (invert . second (getWlForCx cx)) $ vs+          where+            invert (did, wl)+                = map (second (toIntermediate . Occ.singleton' did)) $ M.toList wl+            getWlForCx cx' ws'+                = fromMaybe M.empty (M.lookup cx' ws')++----------------------------------------------------------------------------+-- addWords/batchAddWords functions+----------------------------------------------------------------------------++mapWithKeyMP :: (Par.MonadParallel m, Ord k) => (k -> a -> m b) -> M.Map k a -> m (M.Map k b)+mapWithKeyMP f m =+  (Par.mapM (\(k, a) -> do+                  b <- f k a+                  return (k, b)+                ) $ M.toList m) >>=+    return . M.fromList++----------------------------------------------------------------------------++-- | Inserts a new context.+--+insertContext :: Context -> Impl.IndexImpl -> ContextSchema+              -> ContextIndex dt -> ContextIndex dt+insertContext c ix schema (ContextIndex m dt)+    = ContextIndex  m' dt+    where+    m' = insertContext' c schema ix m++--   /Note/: Does nothing if the context already exists.+insertContext' :: Context -> ContextSchema -> Impl.IndexImpl -> ContextMap -> ContextMap+insertContext' c s ix (ContextMap m) = mkContextMap $ M.insertWith (const id) c (s, ix) m++-- | Removes context (including the index and the schema).+deleteContext :: Context -> ContextIndex dt -> ContextIndex dt+deleteContext c (ContextIndex ix dt) = ContextIndex (deleteContext' c ix) dt++-- | Removes context (includes the index, but not the schema).+deleteContext' :: Context -> ContextMap -> ContextMap+deleteContext' cx (ContextMap m) = mkContextMap $ M.delete cx m++delete' :: Par.MonadParallel m => DocIdSet -> ContextMap -> m ContextMap+delete' dIds (ContextMap m)+  = mapWithKeyMP (\_ impl -> adjust' impl) m >>= return . mkContextMap+--  = TV.mapM adjust' m >>= return . mkContextMap+  where+  adjust' (s, Impl.IndexImpl ix) = Ix.deleteDocsM dIds ix >>= \i -> return (s, Impl.mkIndex i)++{- not yet used++-- | Search query in all context.+search :: Monad m => TextSearchOp -> Text -> ContextMap -> m [(Context, [(Text, v)])]+search op k (ContextMap m)+  = liftM M.toList $ TV.mapM search' m+  where+  search' (Impl.IndexImpl ix) = Ix.searchM op k ix+-- -}++-- | Range query in a context between first and second key.+lookupRangeCx :: Monad m => Context -> Text -> Text -> ContextMap -> m [(Text, IntermediateValue)]+lookupRangeCx c k1 k2 cm+    = lookupIndex c cm $ Ix.lookupRangeM k1 k2++-- | Dump a context+lookupAllWithCx :: Monad m => Context -> ContextMap -> m [(Text, IntermediateValue)]+lookupAllWithCx cx cm+    = lookupIndex cx cm $ Ix.toListM++-- | Search query in a context.+searchWithCx :: Monad m => TextSearchOp -> Context -> Text -> ContextMap -> m [(Text, IntermediateValue)]+searchWithCx op cx w cm+    = lookupIndex cx cm $ Ix.searchM op w+++-- | Search over a list of contexts and words+searchWithCxsNormalized :: (Functor m, Monad m) =>+                           TextSearchOp -> [(Context, Text)] -> ContextMap ->+                           m [(Context, [(Text, IntermediateValue)])]+searchWithCxsNormalized op cxws cm+    = P.mapM (uncurry search') cxws+    where+      search' cx w+          = (\ x -> (cx, x))+            <$> (lookupIndex cx cm $ Ix.searchM op w)++-- | Search query with scored results+-- XXX TODO: this function should return intermediates and query processor should work with those+searchWithCxSc :: Monad m =>+                  TextSearchOp -> Context -> Text -> ContextMap -> m [(Text, (Score, Occurrences))]+searchWithCxSc op cx w cm+    = (lookupIndex cx cm $ Ix.searchMSc op w) >>= return . fromScoredIntermediates++-- | Range query in a context between first and second key.+-- XXX TODO: this function should return intermediates and query processor should work with those+lookupRangeCxSc :: Monad m => Context -> Text -> Text -> ContextMap -> m [(Text, (Score, Occurrences))]+lookupRangeCxSc c k1 k2 cm+    = (lookupIndex c cm $ Ix.lookupRangeMSc k1 k2) >>= return . fromScoredIntermediates++-- ------------------------------------------------------------++-- | lookup an index by a context and then search this index for a word+-- result is always a list of values.+--+-- This pattern is used in all search variants++lookupIndex :: Monad m =>+               Context -> ContextMap ->+               (forall i . Impl.IndexImplCon i => i -> m [r]) ->+               m [r]+lookupIndex cx (ContextMap m) search+    = case M.lookup cx m of+        Just (_, Impl.IndexImpl cm)+            -> search cm+        Nothing+            -> return []++foreachContext :: (Functor m, Monad m) =>+                  [Context] ->+                  (Context -> m res) ->+                  m [(Context, res)]+foreachContext cxs action+    = P.mapM action' cxs+      where+        action' cx+            = (\ r -> (cx, r)) <$> action cx++-- ------------------------------------------------------------++-- | All contexts of the index.+contextsM :: (Monad m, DocTable dt)+         => ContextIndex dt -> m [Context]+contextsM (ContextIndex ix _) = return $ contexts ix++-- | Contexts/keys of 'ContextMap'.+contexts :: ContextMap -> [Context]+contexts (ContextMap m) = M.keys m++-- | Check if the context exists.+hasContext :: Context -> ContextMap -> Bool+hasContext c (ContextMap m) = M.member c m++-- | Does the context exist?+hasContextM :: (Monad m, DocTable dt)+           => Context -> ContextIndex dt -> m Bool+hasContextM c (ContextIndex ix _) = return $ hasContext c ix++
+ src/Hunt/DocTable.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies      #-}++-- ----------------------------------------------------------------------------+{- |+  The document table interface.+-}+-- ----------------------------------------------------------------------------++module Hunt.DocTable+where++import           Prelude                hiding (filter, lookup, map, null)++import           Control.Applicative    (Applicative, (<$>))+import           Control.Monad++import           Data.Aeson+import           Data.Maybe             (catMaybes, fromJust)+import           Data.Set               (Set)+import qualified Data.Set               as S++import           Hunt.Common.BasicTypes+import           Hunt.Common.DocId+import           Hunt.Common.DocIdMap   (DocIdMap (..))+import qualified Hunt.Common.DocIdMap   as DM+import           Hunt.Common.DocIdSet   (DocIdSet)+import qualified Hunt.Common.DocIdSet   as DS+import           Hunt.Common.Document   (Document,+                                         DocumentWrapper (wrap, unwrap))++-- ------------------------------------------------------------++-- | The document table type class which needs to be implemented to be used by the 'Interpreter'.+--   The type parameter @i@ is the implementation.+--   The implementation must have a value type parameter.++class (DocumentWrapper (DValue i)) => DocTable i where+    -- | The value type of the document table.+    type DValue i :: *++    -- | Test whether the document table is empty.+    null            :: (Monad m) => i -> m Bool++    -- | Returns the number of unique documents in the table.+    size            :: (Monad m) => i -> m Int++    -- | Lookup a document by its ID.+    lookup          :: (Monad m) => DocId -> i -> m (Maybe (DValue i))++    -- | Lookup the 'DocId' of a document by an 'URI'.+    lookupByURI     :: (Monad m) => URI -> i -> m (Maybe DocId)++    -- | Union of two disjoint document tables. It is assumed, that the+    --   DocIds and the document 'URI's of both indexes are disjoint.+    union           :: (Monad m) => i -> i -> m i++    -- | Test whether the 'DocId's of both tables are disjoint.+    disjoint        :: (Monad m) => i -> i -> m Bool++    -- | Insert a document into the table. Returns a tuple of the 'DocId' for that document and the+    --   new table. If a document with the same 'URI' is already present, its id will be returned+    --   and the table is returned unchanged.+    insert          :: (Monad m) => DValue i -> i -> m (DocId, i)++    -- | Update a document with a certain 'DocId'.+    update          :: (Monad m) => DocId -> DValue i -> i -> m i++    -- | Update a document by 'DocId' with the result of the provided function.+    adjust          :: (Monad m) => (DValue i -> m (DValue i)) -> DocId -> i -> m i+    adjust f did d =+        maybe (return d) (upd d did <=< f) =<< lookup did d+        --maybe d (update d did . f) $ lookup d did+        where upd i docid v = update docid v i++    -- | Update a document by 'URI' with the result of the provided function.+    adjustByURI     :: (Monad m) => (DValue i -> m (DValue i)) -> URI -> i -> m i+    adjustByURI f uri d+        = maybe (return d) (flip (adjust f) d) =<< lookupByURI uri d++    -- | Removes the document with the specified 'DocId' from the table.+    delete          :: (Monad m) => DocId -> i -> m i++    -- | Removes the document with the specified 'URI' from the table.+    deleteByURI     :: (Monad m) => URI -> i -> m i+    deleteByURI u ds+        = maybe (return ds) (flip delete ds) =<< lookupByURI u ds++    -- | Deletes a set of documents by 'DocId' from the table.+    difference      :: (Monad m) => DocIdSet -> i -> m i++    -- | Deletes a set of documents by 'URI' from the table.+    differenceByURI :: (Monad m) => Set URI -> i -> m i+    differenceByURI uris d = do -- XXX: eliminate S.toList?+        ids <- liftM (DS.fromList . catMaybes) . mapM (flip lookupByURI d) . S.toList $ uris+        difference ids d++    -- | Map a function over all values of the document table.+    map             :: (Monad m) => (DValue i -> DValue i) -> i -> m i++    -- | Filters all documents that satisfy the predicate.+    filter          :: (Monad m) => (DValue i -> Bool) -> i -> m i++    -- | Convert document table to a 'DocIdMap'.+    toMap           :: (Monad m) => i -> m (DocIdMap (DValue i))++    -- | Empty 'DocTable'.+    empty           :: i+++restrict :: (Functor m, Monad m, Applicative m, DocTable i) => DocIdSet -> i -> m i+restrict is dt+    = foldM ins empty $ DS.toList is+      where+        ins m i = do v <- fromJust <$> lookup i dt+                     update i v m++-- ------------------------------------------------------------++-- | JSON dump of the document table.+toJSON'DocTable :: (Functor m, Monad m, Applicative m, DocTable i) => i -> m Value+toJSON'DocTable dt+    = do didm <- DM.map unwrap <$> toMap dt+         return $ toJSON didm++-- | JSON import of the document table.+fromJSON'DocTable :: (Functor m, Monad m, Applicative m, DocTable i) => Value -> m i+fromJSON'DocTable v+    = foldM ins empty $ dm'+      where+        ins res (did, doc) = update did doc res++        dm :: DocIdMap Document+        dm = case fromJSON v of+               Error _   -> DM.empty+               Success m -> m++        dm'= DM.toList . DM.map wrap $ dm++-- ------------------------------------------------------------
+ src/Hunt/DocTable/HashedDocTable.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies      #-}++-- ----------------------------------------------------------------------------++{- |+  Module     : Hunt.Index.HashedDocTable+  Copyright  : Copyright (C) 2012 Uwe Schmidt+  License    : MIT++  Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+  Stability  : experimental++  A more space efficient substitute for Hunt.Index.Documents+  and a more flexible implementation than Hunt.Index.CompactDocuments.++  DocIds are computed by a hash function, so the inverse map from 'URI's to 'DocId's+  is substituted by the hash function.++  MurmurHash2 64-bit is used as the hash function.+  https://sites.google.com/site/murmurhash/++  It is a fast non-cryptographic hash function with good performance and+  hash distribution properties.+  http://programmers.stackexchange.com/a/145633+-}++-- ----------------------------------------------------------------------------++module Hunt.DocTable.HashedDocTable+    (+      -- * Documents type+      Documents (..)+    , DocMap++      -- * Conversion+    , fromMap+    )+where++import           Data.Binary            (Binary (..))++import           Control.DeepSeq++import           Hunt.Common.BasicTypes+import           Hunt.Common.DocId      (DocId, mkDocId)+import           Hunt.Common.DocIdMap   (DocIdMap)+import qualified Hunt.Common.DocIdMap   as DM+import           Hunt.Common.DocIdSet   (DocIdSet)+import           Hunt.Common.Document   (Document (..), DocumentWrapper (..))+import           Hunt.DocTable+import           Hunt.Utility++-- ------------------------------------------------------------++-- | The table which is used to map a document to an artificial id and vice versa.+type DocMap e+  = DocIdMap e++-- | The 'DocTable' implementation. Maps 'DocId's to 'Document's.+newtype Documents e+  = Documents { idToDoc :: DocMap e }     -- ^ A mapping from a document id to+                                          --   the document itself.+  deriving (Eq, Show)++mkDocuments :: NFData e => DocMap e -> Documents e+mkDocuments m = Documents $! m++-- ------------------------------------------------------------++instance NFData e => NFData (Documents e) where+  rnf (Documents e) = rnf e++instance (DocumentWrapper e, Binary e) => Binary (Documents e) where+  put = put . idToDoc+  get = get >>= return . mkDocuments++--- ------------------------------------------------------------++-- | An empty document table.+empty' :: (DocTable (Documents e), DocumentWrapper e) => Documents e+empty' = mkDocuments DM.empty++-- | Build a 'DocTable' from a 'DocIdMap' (maps 'DocId's to 'Document's)+fromMap :: (DocTable (Documents e), DocumentWrapper e) =>+          (Document -> e) -> DocIdMap Document -> Documents e+fromMap = fromMap'++-- ------------------------------------------------------------++instance (DocumentWrapper e) =>+         DocTable (Documents e) where+  type DValue (Documents e) = e+  null        = return . null'++  -- Returns the number of unique documents in the table.+  size        = return . size'++  -- Lookup a document by its id.+  lookup      = return .:: lookup'++  -- Lookup the id of a document by an URI.+  lookupByURI = return .:: lookupByURI'++  -- Union of two disjoint document tables. It is assumed, that the DocIds and the document uris+  -- of both indexes are disjoint. If only the sets of uris are disjoint, the DocIds can be made+  -- disjoint by adding maxDocId of one to the DocIds of the second, e.g. with editDocIds+  union       = return .:: unionDocs'++  -- Test whether the doc ids of both tables are disjoint.+  disjoint    = return .:: disjoint'++  -- Insert a document into the table. Returns a tuple of the id for that document and the+  -- new table. If a document with the same URI is already present, its id will be returned+  -- and the table is returned unchanged.+  insert      = return .:: insert'++  -- Update a document with a certain DocId.+  update      = return .::: update'++  -- Removes the document with the specified id from the table.+  delete      = return .:: delete'++  -- Deletes a set of Docs by Id from the table.+  difference  = return .:: difference'++  -- Update documents (through mapping over all documents).+  map         = return .:: map'++  -- Filters all documents that satisfy the predicate.+  filter      = return .:: filter'++  -- Convert document table to a single map.+  toMap       = return . toMap'++  -- | Empty 'DocTable'.+  empty       = empty'++-- ------------------------------------------------------------++null'       :: (DocumentWrapper e) => Documents e -> Bool+null'+  = DM.null . idToDoc++size'       :: (DocumentWrapper e) => Documents e -> Int+size'+  = DM.size . idToDoc++lookup'     :: (Monad m, DocumentWrapper e) => DocId -> Documents e -> m e+lookup' i d+  = maybe (fail "") return+    . DM.lookup i+    . idToDoc+    $ d++lookupByURI' :: (Monad m, DocumentWrapper e) => URI -> Documents e -> m DocId+lookupByURI' u d+  = maybe (fail "") (const $ return i)+    . DM.lookup i+    . idToDoc+    $ d+  where+  i = mkDocId u++disjoint'   :: (DocumentWrapper e) => Documents e -> Documents e -> Bool+disjoint' dt1 dt2+  = DM.null $ DM.intersection (idToDoc dt1) (idToDoc dt2)++unionDocs'  :: (DocumentWrapper e) => Documents e -> Documents e -> Documents e+unionDocs' dt1 dt2+  | disjoint' dt1 dt2+      = unionDocs'' dt1 dt2+  | otherwise+      = error+        "HashedDocTable.unionDocs: doctables are not disjoint"+  where+  unionDocs'' :: (DocumentWrapper e) => Documents e -> Documents e -> Documents e+  unionDocs'' dt1' dt2'+    = mkDocuments $ idToDoc dt1' `DM.union` idToDoc dt2'+++insert'     :: (DocumentWrapper e) => e -> Documents e -> (DocId, Documents e)+insert' d ds+  = maybe reallyInsert (const (newId, ds)) (lookup' newId ds)+  where+  newId+      = mkDocId . uri . unwrap $ d+  reallyInsert+      = (newId, mkDocuments $ DM.insert newId d $ idToDoc ds)++update'     :: (DocumentWrapper e) => DocId -> e -> Documents e -> Documents e+update' i d ds+  = mkDocuments $ DM.insert i d $ idToDoc ds++delete'     :: (DocumentWrapper e) => DocId -> Documents e -> Documents e+delete' d ds+  = mkDocuments $ DM.delete d $ idToDoc ds++difference' :: (DocumentWrapper e) => DocIdSet -> Documents e -> Documents e+difference' s ds+  = mkDocuments $ idToDoc ds `DM.diffWithSet` s++map'        :: (DocumentWrapper e) => (e -> e) -> Documents e -> Documents e+map' f d+  = mkDocuments $ DM.map f (idToDoc d)++filter'     :: (DocumentWrapper e) => (e -> Bool) -> Documents e -> Documents e+filter' p d+  = mkDocuments $ DM.filter p (idToDoc d)++fromMap'    :: (DocumentWrapper e) => (Document -> e) -> DocIdMap Document -> Documents e+fromMap' f itd+  = mkDocuments $ DM.map f itd++toMap'      :: Documents e -> DocIdMap e+toMap'+  = idToDoc++-- ------------------------------------------------------------
+ src/Hunt/Index.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE UndecidableInstances      #-}+{-# LANGUAGE MultiParamTypeClasses     #-}++-- ----------------------------------------------------------------------------+{- |+  The index interface.+-}+-- ----------------------------------------------------------------------------+++module Hunt.Index+where++import           Prelude                hiding (map)++import           GHC.Exts               (Constraint)++import           Control.Arrow          (second)++import qualified Data.List              as L++import           Hunt.Common.BasicTypes+import           Hunt.Common.DocId+import           Hunt.Common.DocIdSet   (DocIdSet)+import qualified Hunt.Common.DocIdSet   as DS+import           Hunt.Common.IntermediateValue++-- ------------------------------------------------------------++-- | The index type class which needs to be implemented to be used by the 'Interpreter'.+--   The type parameter @i@ is the implementation.+--   The implementation must have a value type parameter.+class (IndexValue (IVal i)) => Index i where+  -- | The key type of the index.+  type IKey i :: *+  type IVal i :: *++  type ICon i :: Constraint+  type ICon i = ()++  -- | General lookup function.+  search        :: ICon i => TextSearchOp -> IKey i -> i -> [(IKey i, IntermediateValue)]++  searchSc      :: ICon i => TextSearchOp -> IKey i -> i -> [(IKey i, (Score, IntermediateValue))]+  searchSc op k ix = addDefScore $ search op k ix++  -- | Search within a range of two keys.+  lookupRange   :: ICon i => IKey i -> IKey i -> i -> [(IKey i, IntermediateValue)]++  lookupRangeSc :: ICon i => IKey i -> IKey i -> i -> [(IKey i, (Score, IntermediateValue))]+  lookupRangeSc k1 k2 ix+                = addDefScore $ lookupRange k1 k2 ix++  -- | Insert occurrences.+  --   This is more efficient than folding with 'insert'.+  insertList    :: ICon i =>+                   [(IKey i, IntermediateValue)] -> i -> i++  -- | Insert occurrences.+  insert        :: ICon i =>+                   IKey i -> IntermediateValue -> i -> i+  insert   k v  = insertList [(k,v)]++  -- | Delete as batch job.+  --   This is more efficient than folding with 'delete'.+  deleteDocs    :: ICon i => DocIdSet -> i -> i++  -- | Delete occurrences.+  delete        :: ICon i => DocId -> i -> i+  delete        = deleteDocs . DS.singleton++  -- | Empty index.+  empty         :: ICon i => i++  -- | Convert an index to a list.+  --   Can be used for easy conversion between different index implementations.+  toList        :: ICon i => i -> [(IKey i, IntermediateValue)]++  -- | Convert a list of key-value pairs to an index.+  fromList      :: ICon i => [(IKey i, IntermediateValue)] -> i++  -- | Merge two indexes with a combining function.+  unionWith     :: ICon i+                => (IVal i -> IVal i -> IVal i)+                -> i -> i -> i++  --   Merge two indexes with combining functions.+  --   The second index may have another value type than the first one.+  --   Conversion and merging of the indexes is done in a single step.+  --   This is much more efficient than mapping the second index and calling 'unionWith'.+  --  unionWithConv :: (ICon i, ICon i2)+  --                => IVal i)2 -> IVal i) -> (v -> v2 -> IVal i)+  --                -> i -> i2 -> i++  -- TODO: non-rigid map+  -- | Map a function over the values of the index.+  map           :: ICon i+                => (IVal i -> IVal i)+                -> i -> i+  map f = mapMaybe (Just . f)++  -- | Updates a value or deletes it if the result of the function is 'Nothing'.+  mapMaybe      :: ICon i+                => (IVal i -> Maybe (IVal i))+                -> i -> i++  -- | Keys of the index.+  keys          :: ICon i+                => i -> [IKey i]++-- ------------------------------------------------------------++-- | Monadic version of 'Index'.+--   'Index' instances are automatically instance of this type class.+class Monad m => IndexM m i where+  -- | The key type of the index.+  type IKeyM     i :: *++  -- | The value type of the index.+  type IValM     i :: *++  type IConM     i :: Constraint+  type IConM     i = ()++  -- | Monadic version of 'search'.+  searchM      :: IConM i => TextSearchOp -> IKeyM i -> i -> m [(IKeyM i, IntermediateValue)]++  -- | Monadic version of 'search' with (default) scoring.+  searchMSc     :: IConM i => TextSearchOp -> IKeyM i -> i -> m [(IKeyM i, (Score, IntermediateValue))]+  searchMSc op k ix+                = searchM op k ix >>= return . addDefScore++  -- | Monadic version of 'lookupRangeM'.+  lookupRangeM :: IConM i => IKeyM i -> IKeyM i -> i -> m [(IKeyM i, IntermediateValue)]++  lookupRangeMSc :: IConM i => IKeyM i -> IKeyM i -> i -> m [(IKeyM i, (Score, IntermediateValue))]+  lookupRangeMSc k1 k2 ix+                = lookupRangeM k1 k2 ix >>= return . addDefScore++  -- | Monadic version of 'insertList'.+  insertListM  :: IConM i =>+                  [(IKeyM i, IntermediateValue)] -> i -> m (i)++  -- | Monadic version of 'insert'.+  insertM      :: IConM i =>+                  IKeyM i -> IntermediateValue -> i -> m (i)+  insertM k v  = insertListM [(k,v)]++  -- | Monadic version of 'deleteDocs'.+  deleteDocsM  :: IConM i => DocIdSet -> i -> m (i)++  -- | Monadic version of 'delete'.+  deleteM      :: IConM i => DocId -> i -> m (i)+  deleteM k i  = deleteDocsM (DS.singleton k) i++  -- | Monadic version of 'empty'.+  emptyM       :: IConM i => m (i)++  -- | Monadic version of 'toList'.+  toListM      :: IConM i => i -> m [(IKeyM i, IntermediateValue)]++  -- | Monadic version of 'fromList'.+  fromListM    :: IConM i => [(IKeyM i, IntermediateValue)] -> m (i)++  -- | Monadic version of 'unionWith'.+  unionWithM   :: IConM i =>+                  (IValM i -> IValM i -> IValM i) ->+                  i -> i -> m (i)++  --  Monadic version of 'unionWithConv'.+  -- unionWithConvM :: (IConM i, Monad m, IConM i2)+  --               => IVal i)2 -> IVal i) -> (v -> v2 -> IVal i)+  --               -> i -> i2 -> m (i)++  -- | Monadic version of 'map'.+  mapM         :: IConM i+               => (IValM i -> IValM i)+               -> i -> m (i)+  mapM f = mapMaybeM (Just . f)++  -- | Monadic version of 'mapMaybe'.+  mapMaybeM    :: IConM i+               => (IValM i -> Maybe (IValM i))+               -> i -> m (i)++  -- | Monadic version of 'keys'.+  keysM        :: IConM i+               => i -> m [IKeyM i]++-- ------------------------------------------------------------++instance (Index i, Monad m) => IndexM m i where+  type IKeyM i             = IKey i+  type IValM i             = IVal i+  type IConM i             = ICon i++  searchM   op s i           = return $  search op s i+  searchMSc op s i           = return $  searchSc op s i+  lookupRangeM   l u i       = return $  lookupRange   l u i+  lookupRangeMSc l u i       = return $  lookupRangeSc l u i+  insertListM  vs i          = return $! insertList vs i+  deleteDocsM ds i           = return $! deleteDocs ds i+  insertM k v i              = return $! insert k v i+  deleteM k i                = return $! delete k i+  emptyM                     = return $! empty+  toListM i                  = return $  toList i+  fromListM l                = return $! fromList l+  unionWithM f i1 i2         = return $! unionWith f i1 i2+--  unionWithConvM f1 f2 i1 i2 = return $! unionWithConv f1 f2 i1 i2+  mapM f i                   = return $! map f i+  mapMaybeM f i              = return $! mapMaybe f i+  keysM i                    = return $  keys i++-- ------------------------------------------------------------++addDefScore :: [(a, b)] -> [(a, (Score, b))]+addDefScore = L.map (second (\ x -> (defScore, x)))++-- ------------------------------------------------------------
+ src/Hunt/Index/IndexImpl.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE TypeFamilies              #-}++-- ----------------------------------------------------------------------------+{- |+  Heterogeneous indexes using @ExistentialQuantification@.++  Indexes have to implement the 'Index' type class as well as obey other constraints defined in+  'IndexImplCon'.++  /Note/: Due to the nature of @ExistentialQuantification@, deserialization is tricky because the+  concrete implementation is not known.+  This is circumvented by storing the type representation of the index. Deserialization is possible+  if there is a matching type representation in the set of available types.+  This requires the use of the custom get functions.+-}+-- ----------------------------------------------------------------------------++module Hunt.Index.IndexImpl where++import           Control.Applicative         ((<$>))+import           Control.DeepSeq+import           Control.Monad++import           Data.Binary+import qualified Data.List                   as L+import           Data.Text                   (Text)+import           Data.Text.Binary            ()+import           Data.Typeable+import           Data.Typeable.Binary        ()++import           Hunt.Common.BasicTypes+import           Hunt.Common.IntermediateValue+import           Hunt.Index++-- ------------------------------------------------------------++-- | Constraint for index implementations.+type IndexImplCon i+  = ( Index i+    , Show i+    , ICon i+    , IndexValue (IVal i)+    , Binary i+    , Typeable i+    , IKey i ~ Text+    )++-- ------------------------------------------------------------++-- | Index using @ExistentialQuantification@ to allow heterogeneous index containers.+data IndexImpl+  = forall i. IndexImplCon i => IndexImpl { ixImpl :: i }++-- ------------------------------------------------------------++instance Show IndexImpl where+  show (IndexImpl v) = show v++-- FIXME: not 'rnf v `seq` ()'. is it supposed to be that way?+instance NFData IndexImpl where+  rnf (IndexImpl v) = v `seq` ()++-- ------------------------------------------------------------+-- Serialization++-- | FIXME: actually implement instance+instance Binary IndexImpl where+  put (IndexImpl i) = put (typeOf i) >> put i+  get = error "existential types cannot be deserialized this way. Use special get' functions"++-- TODO: refactor++-- | Deserialize a set of 'IndexImpl's. Requires a set of available index implementations.+--+--   /Note/: This will fail if a used index implementation is not provided.+gets' :: [IndexImpl] -> Get [(Context, IndexImpl)]+gets' ts = do+  n <- get :: Get Int+  go [] n+  where+  go xs 0 = return $! reverse xs+  go xs i = do+    x <- liftM2 (,) get (get' ts)+    x `seq` go (x:xs) (i-1)++-- | Deserialize an 'IndexImpl'. Requires a set of available index implementations.+--+--   /Note/: This will fail if a used index implementation is not provided.+get' :: [IndexImpl] -> Get (IndexImpl)+get' ts = do+  t <- get :: Get TypeRep+  case L.find (\(IndexImpl i) -> t == typeOf i) ts of+    Just (IndexImpl x) -> IndexImpl <$> get `asTypeOf` return x+    Nothing            -> error $ "Unable to load index of type: " -- ++ show t++-- ------------------------------------------------------------++-- | Wrap an index using @ExistentialQuantification@ to allow heterogeneous containers.+mkIndex :: IndexImplCon i => i -> IndexImpl+mkIndex i = IndexImpl $! i++-- ------------------------------------------------------------
+ src/Hunt/Index/InvertedIndex.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverlappingInstances       #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances        #-}++-- ----------------------------------------------------------------------------+{- |+  Top-level index implementations with 'Text' keys for++    * text++    * integers++    * dates and++    * geographic positions.+-}+-- ----------------------------------------------------------------------------++module Hunt.Index.InvertedIndex+{-+  ( InvertedIndex (..)+  , InvertedIndexDate+  , InvertedIndexInt+  , InvertedIndexPosition+  , InvertedIndexRTree+  )+-- -}+where++import           Prelude                              as P++import           Control.DeepSeq++import           Data.Bijection.Instances             ()+import           Data.Binary                          (Binary (..))+import qualified Data.List                            as L+import           Data.Text                            (Text)+import qualified Data.Text                            as T+import           Data.Typeable++import           Hunt.Common.BasicTypes+import           Hunt.Common.Occurrences              (Occurrences)+import           Hunt.Index                           as Ix+import           Hunt.Index.PrefixTreeIndex+import qualified Hunt.Index.PrefixTreeIndex2Dim       as PT2D++import           Hunt.Index.Proxy.KeyIndex+++-- ------------------------------------------------------------+-- Inverted index using text key+-- ------------------------------------------------------------++-- | Text index using a 'StringMap'-implementation.+newtype InvertedIndex+  = InvIx { invIx :: KeyProxyIndex Text (DmPrefixTree Occurrences) }+  deriving (Eq, Show, NFData, Typeable)++mkInvIx :: KeyProxyIndex Text (DmPrefixTree Occurrences)+        -> InvertedIndex+mkInvIx x = InvIx $! x++-- ------------------------------------------------------------++instance Binary InvertedIndex where+  put = put . invIx+  get = get >>= return . mkInvIx++-- ------------------------------------------------------------++instance Index InvertedIndex where+  type IKey InvertedIndex = Word+  type IVal InvertedIndex = Occurrences++  insertList wos (InvIx i)+    = mkInvIx $ insertList wos i++  deleteDocs docIds (InvIx i)+    = mkInvIx $ deleteDocs docIds i++  empty+    = mkInvIx $ empty++  fromList l+    = mkInvIx $ fromList l++  toList (InvIx i)+    = toList i++  search t k (InvIx i)+    = search t k i++  -- here the scoring of found word rel. to searched word is added+  searchSc t k m+      = L.map scoreWord $ search t k m+        where+          dist+              = similar k+          scoreWord (w, r)+              = (w, (dist w, r))+++  lookupRange k1 k2 (InvIx i)+    = lookupRange k1 k2 i++  -- for lookupRangeSc the default scoring (all 1.0) is done+  --+  -- no better scoring known++  unionWith op (InvIx i1) (InvIx i2)+    = mkInvIx $ unionWith op i1 i2++{-+  unionWithConv to f (InvIx i1) (InvIx i2)+    = mkInvIx $ unionWithConv to f i1 i2+-}++  map f (InvIx i)+    = mkInvIx $ Ix.map f i++  mapMaybe f (InvIx i)+    = mkInvIx $ Ix.mapMaybe f i++  keys (InvIx i)+    = keys i+++-- ------------------------------------------------------------++-- | a simple similarity heuristic for scoring words found+-- when doing a fuzzy or prefix search++similar :: Text -> Text -> Score+similar s f+    = -- traceShow ("similar"::Text, s, f, r) $+      r+    where+      r = similar' s f++similar' :: Text -> Text -> Score+similar' searched found+    | searched == found+        = 1.0+    | ls == lf+        = 0.75+    | ls < lf                     -- reduce score by length of found word+        = 0.5 * (fromIntegral ls / fromIntegral lf)+    | otherwise                   -- make similar total+        = noScore+    where+      ls = T.length searched+      lf = T.length found++-- ------------------------------------------------------------+-- Inverted index using 2-dimensional lookup+-- ------------------------------------------------------------++-- | Text index with 2-dimensional lookup using a 'StringMap'-implementation.+newtype InvertedIndex2Dim+  = InvIx2D { invIx2D :: KeyProxyIndex Text (PT2D.DmPrefixTree Occurrences) }+  deriving (Eq, Show, NFData, Typeable)++mkInvIx2D :: KeyProxyIndex Text (PT2D.DmPrefixTree Occurrences)+        -> InvertedIndex2Dim+mkInvIx2D x = InvIx2D $! x++-- ------------------------------------------------------------++instance Binary InvertedIndex2Dim where+  put = put . invIx2D+  get = get >>= return . mkInvIx2D++-- ------------------------------------------------------------++instance Index InvertedIndex2Dim where+  type IKey InvertedIndex2Dim = Word+  type IVal InvertedIndex2Dim = Occurrences++  insertList wos (InvIx2D i)+    = mkInvIx2D $ insertList wos i++  deleteDocs docIds (InvIx2D i)+    = mkInvIx2D $ deleteDocs docIds i++  empty+    = mkInvIx2D $ empty++  fromList l+    = mkInvIx2D $ fromList l++  toList (InvIx2D i)+    = toList i++  search t k (InvIx2D i)+    = search t k i++  -- TODO: searchSc and lookupRangeSc implementation similar to InvertedIndexInt and InvertedIndex++  lookupRange k1 k2 (InvIx2D i)+    = lookupRange k1 k2 i++  unionWith op (InvIx2D i1) (InvIx2D i2)+    = mkInvIx2D $ unionWith op i1 i2++{-+  unionWithConv to f (InvIx2D i1) (InvIx2D i2)+    = mkInvIx2D $ unionWithConv to f i1 i2+-}++  map f (InvIx2D i)+    = mkInvIx2D $ Ix.map f i++  mapMaybe f (InvIx2D i)+    = mkInvIx2D $ Ix.mapMaybe f i++  keys (InvIx2D i)+    = keys i+++
+ src/Hunt/Index/PrefixTreeIndex.hs view
@@ -0,0 +1,407 @@+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies               #-}++-- ----------------------------------------------------------------------------+{- |+  Text index using the 'DocIdMap' based on the 'StringMap' implementation.+-}+-- ----------------------------------------------------------------------------++module Hunt.Index.PrefixTreeIndex+    ( DmPrefixTree (..)+    , SimplePrefixTreeIndex (..)+    , PrefixTreeIndexInt (..)+    , PrefixTreeIndexDate (..)+    )+where++import           Control.DeepSeq++import           Data.Binary            (Binary (..))+import qualified Data.List              as L+import qualified Data.StringMap.Strict  as SM+import           Data.Typeable+import           Data.Bijection+import           Data.Bijection.Instances ()++import           Data.Text              (Text)+import qualified Data.Text              as T+import           Data.Maybe             (fromMaybe)++import           Text.Read              (readMaybe)++import           Hunt.Common.BasicTypes+import           Hunt.Common.DocIdSet   (DocIdSet)+import           Hunt.Common.IntermediateValue+import           Hunt.Index+import qualified Hunt.Index             as Ix+import           Hunt.Index.Proxy.KeyIndex++import           Hunt.Utility++import qualified Hunt.Index.Schema.Normalize.Date     as Date+import qualified Hunt.Index.Schema.Normalize.Int      as Int+++++-- import           Debug.Trace++-- ------------------------------------------------------------++-- | Text index using 'DocIdMap' based on the 'StringMap' implementation.+--   Note that the value parameter is on the type of the 'DocIdMap' value and not the 'DocIdSet'+--   itself.++newtype DmPrefixTree v+  = DmPT { dmPT :: SM.StringMap v}+  deriving (Eq, Show, NFData, Typeable)++mkDmPT :: NFData v => SM.StringMap v -> DmPrefixTree v+mkDmPT v = DmPT $! v++-- ------------------------------------------------------------++instance IndexValue v => Binary (DmPrefixTree v) where+  put = put . dmPT+  get = get >>= return . mkDmPT++-- ------------------------------------------------------------++instance (IndexValue v) => Index (DmPrefixTree v)  where+  type IKey (DmPrefixTree v) = SM.Key+  type IVal (DmPrefixTree v) = v++  insertList kvs (DmPT pt) =+    mkDmPT $ L.foldl' (\ m' (k', v') -> SM.insertWith mergeValues k' v' m') pt (fromIntermediates kvs)++    {- this is a nice try, but does not do what it should do,+       at least for [("a", occ1), ("a", occ2)]++       mkDmPT $ SM.unionWith op pt (SM.fromList kvs)+    -}++  deleteDocs ks (DmPT pt)+    = mkDmPT $ SM.mapMaybe (diffValues ks) pt++  empty+    = mkDmPT $ SM.empty++  fromList+    = mkDmPT . SM.fromList . fromIntermediates++  toList (DmPT pt)+    = toIntermediates $ SM.toList pt++  search t k (DmPT pt)+    = toIntermediates $ case t of+        Case         -> case SM.lookup k pt of+                          Nothing -> []+                          Just xs -> [(k,xs)]+        NoCase       -> luCase k pt+        PrefixCase   -> pfCase k pt+        PrefixNoCase -> pfNoCase k pt+    where+    toL      = SM.toListShortestFirst+    luCase   = toL .:: SM.lookupNoCase+    pfCase   = toL .:: SM.prefixFilter+    pfNoCase = toL .:: SM.prefixFilterNoCase++  lookupRange k1 k2 (DmPT pt)+    = toIntermediates . SM.toList $ SM.lookupRange k1 k2 pt++  unionWith op (DmPT pt1) (DmPT pt2)+    = mkDmPT $ SM.unionWith op pt1 pt2++{-+  unionWithConv to f (DmPT i1) (DmPT i2)+    = liftM mkDmPT $ unionWithConv to f i1 i2+-}++  map f (DmPT pt)+    = mkDmPT $ SM.map f pt++  mapMaybe f (DmPT pt)+    = mkDmPT $ SM.mapMaybe f pt++  keys (DmPT pt)+    = SM.keys pt++-- ------------------------------------------------------------+-- Simple minimal PrefixTreeIndex based on the 'StringMap'+-- ------------------------------------------------------------++-- | Integer index using a 'StringMap'-implementation.+newtype SimplePrefixTreeIndex+  = SimplePTIx { simplePTIx :: KeyProxyIndex Text (DmPrefixTree DocIdSet) }+  deriving (Eq, Show, NFData, Typeable)++mkSimplePTIx :: KeyProxyIndex Text (DmPrefixTree DocIdSet) -> SimplePrefixTreeIndex+mkSimplePTIx x = SimplePTIx $! x++-- ------------------------------------------------------------++instance Binary SimplePrefixTreeIndex where+  put = put . simplePTIx+  get = get >>= return . mkSimplePTIx++-- ------------------------------------------------------------++instance Index SimplePrefixTreeIndex where+  type IKey SimplePrefixTreeIndex = Text+  type IVal SimplePrefixTreeIndex = DocIdSet++  insertList wos (SimplePTIx i)+    = mkSimplePTIx $ insertList wos i++  deleteDocs docIds (SimplePTIx i)+    = mkSimplePTIx $ deleteDocs docIds i++  empty+    = mkSimplePTIx $ empty++  fromList l+    = mkSimplePTIx $ fromList l++  toList (SimplePTIx i)+    = toList i++  search t k (SimplePTIx i)+    = search t k i++  searchSc t k m+      = L.map scoreWord $ search t k m+        where+          dist+              = similarInt k+          scoreWord (w, r)+              = (w, (dist w, r))++  lookupRange k1 k2 (SimplePTIx i)+    = lookupRange k1 k2 i++  lookupRangeSc k1 k2 m+    = L.map scoreWord $ lookupRange k1 k2 m+      where+        dist+            = similarRangeInt k1 k2+        scoreWord (w, r)+            = (w, (dist w, r))++  unionWith op (SimplePTIx i1) (SimplePTIx i2)+    = mkSimplePTIx $ unionWith op i1 i2++--  unionWithConv to' f (SimplePTIx i1) (SimplePTIx i2)+--    = mkSimplePTIx $ unionWithConv to' f i1 i2++  map f (SimplePTIx i)+    = mkSimplePTIx $ Ix.map f i++  mapMaybe f (SimplePTIx i)+    = mkSimplePTIx $ Ix.mapMaybe f i++  keys (SimplePTIx i)+    = keys i+++-- ------------------------------------------------------------+-- PrefixTree index using int proxy for numeric data+-- ------------------------------------------------------------++-- | Newtype to allow integer normalization 'Bijection' instance.+newtype UnInt = UnInt { unInt :: Text }+  deriving (Show, Eq, NFData)++instance Bijection UnInt Text where+  to   = Int.denormalizeFromText . unInt+  from = UnInt . Int.normalizeToText++instance Bijection Text UnInt where+  to   = UnInt+  from = unInt++-- ------------------------------------------------------------++-- | Integer index using a 'StringMap'-implementation.+newtype PrefixTreeIndexInt+  = InvIntIx { invIntIx :: KeyProxyIndex Text (KeyProxyIndex UnInt (KeyProxyIndex Text (DmPrefixTree DocIdSet))) }+  deriving (Eq, Show, NFData, Typeable)++mkInvIntIx :: KeyProxyIndex Text (KeyProxyIndex UnInt (KeyProxyIndex Text (DmPrefixTree DocIdSet))) -> PrefixTreeIndexInt+mkInvIntIx x = InvIntIx $! x++-- ------------------------------------------------------------++instance Binary PrefixTreeIndexInt where+  put = put . invIntIx+  get = get >>= return . InvIntIx++-- ------------------------------------------------------------++instance Index PrefixTreeIndexInt where+  type IKey PrefixTreeIndexInt = Text+  type IVal PrefixTreeIndexInt = DocIdSet++  insertList wos (InvIntIx i)+    = mkInvIntIx $ insertList wos i++  deleteDocs docIds (InvIntIx i)+    = mkInvIntIx $ deleteDocs docIds i++  empty+    = mkInvIntIx $ empty++  fromList l+    = mkInvIntIx $ fromList l++  toList (InvIntIx i)+    = toList i++  search t k (InvIntIx i)+    = search t k i++  searchSc t k m+      = L.map scoreWord $ search t k m+        where+          dist+              = similarInt k+          scoreWord (w, r)+              = (w, (dist w, r))++  lookupRange k1 k2 (InvIntIx i)+    = lookupRange k1 k2 i++  lookupRangeSc k1 k2 m+    = L.map scoreWord $ lookupRange k1 k2 m+      where+        dist+            = similarRangeInt k1 k2+        scoreWord (w, r)+            = (w, (dist w, r))++  unionWith op (InvIntIx i1) (InvIntIx i2)+    = mkInvIntIx $ unionWith op i1 i2++--  unionWithConv to' f (InvIntIx i1) (InvIntIx i2)+--    = mkInvIntIx $ unionWithConv to' f i1 i2++  map f (InvIntIx i)+    = mkInvIntIx $ Ix.map f i++  mapMaybe f (InvIntIx i)+    = mkInvIntIx $ Ix.mapMaybe f i++  keys (InvIntIx i)+    = keys i+++similarInt :: Text -> Text -> Score+similarInt searched found+    = fromMaybe noScore $+      do s <- readMaybe $ T.unpack searched+         f <- readMaybe $ T.unpack found+         return $ similarFloat (fromIntegral (s::Int)) (fromIntegral (f::Int))++similarRangeInt :: Text -> Text -> Text -> Score+similarRangeInt lbt ubt found+    = fromMaybe noScore $+      do lb <- readMaybe $ T.unpack lbt+         ub <- readMaybe $ T.unpack ubt+         f  <- readMaybe $ T.unpack found+         return $ similarFloat+                    (fromIntegral ((lb::Int) + (ub::Int)) / 2.0)+                    (fromIntegral (f::Int))++similarFloat :: Float -> Float -> Score+similarFloat mu+    = mkScore . bellCurve (sigma mu) mu++sigma :: Float -> Float+sigma x+    = abs x `max` 10.0 / 10.0++-- | Gaussian bell curve for scoring+bellCurve :: Float -> (Float -> Float -> Float)+bellCurve sigma'+    = \ mu x -> exp (- (x - mu) ^ _2 / sigma2'2)+    where+      _2 :: Int+      _2 = 2+      sigma2'2 = 2.0 * sigma' ^ _2++-- ------------------------------------------------------------+-- inverted index using date proxy for dates+-- ------------------------------------------------------------++-- | Newtype to allow date normalization 'Bijection' instance.+newtype UnDate = UnDate { unDate :: Text }+  deriving (Show, Eq, NFData)++instance Bijection UnDate Text where+  to   = Date.denormalize . unDate+  from = UnDate . Date.normalize++instance Bijection Text UnDate where+  to   = UnDate+  from = unDate++-- ------------------------------------------------------------++-- | Date index using a 'StringMap'-implementation.+newtype PrefixTreeIndexDate+  = InvDateIx { invDateIx :: KeyProxyIndex Text (KeyProxyIndex UnDate (KeyProxyIndex Text (DmPrefixTree DocIdSet))) }+  deriving (Eq, Show, NFData, Typeable)++mkInvDateIx :: KeyProxyIndex Text (KeyProxyIndex UnDate (KeyProxyIndex Text (DmPrefixTree DocIdSet))) -> PrefixTreeIndexDate+mkInvDateIx x = InvDateIx $! x++-- ------------------------------------------------------------++instance Binary PrefixTreeIndexDate where+  put = put . invDateIx+  get = get >>= return . mkInvDateIx++-- ------------------------------------------------------------++instance Index PrefixTreeIndexDate where+  type IKey PrefixTreeIndexDate = Word+  type IVal PrefixTreeIndexDate = DocIdSet++  insertList wos (InvDateIx i)+    = mkInvDateIx $ insertList wos i++  deleteDocs docIds (InvDateIx i)+    = mkInvDateIx $ deleteDocs docIds i++  empty+    = mkInvDateIx $ empty++  fromList l+    = mkInvDateIx $ fromList l++  toList (InvDateIx i)+    = toList i++  search t k (InvDateIx i)+    = search t k i++  -- TODO: searchSc and lookupRangeSc implementation similar to PrefixTreeIndexInt and InvertedIndex++  lookupRange k1 k2 (InvDateIx i)+    = lookupRange k1 k2 i++  unionWith op (InvDateIx i1) (InvDateIx i2)+    = mkInvDateIx $ unionWith op i1 i2++--  unionWithConv to' f (InvDateIx i1) (InvDateIx i2)+--    = mkInvDateIx $ unionWithConv to' f i1 i2++  map f (InvDateIx i)+    = mkInvDateIx $ Ix.map f i++  mapMaybe f (InvDateIx i)+    = mkInvDateIx $ Ix.mapMaybe f i++  keys (InvDateIx i)+    = Ix.keys i
+ src/Hunt/Index/PrefixTreeIndex2Dim.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies               #-}++-- ----------------------------------------------------------------------------+{- |+  Text index using the 'DocIdMap' based on the 'StringMap' implementation.+-}+-- ----------------------------------------------------------------------------++module Hunt.Index.PrefixTreeIndex2Dim+( DmPrefixTree(..)+, PrefixTreeIndexPosition+)+where++import           Control.DeepSeq++import           Data.Binary               (Binary (..))+import           Data.Typeable++import qualified Data.StringMap.Dim2Search as SM2+import qualified Data.StringMap.Strict     as SM+import           Data.Bijection+import           Data.Bijection.Instances  ()+import           Data.Text                 (Text)++import           Hunt.Common.BasicTypes+import           Hunt.Common.DocIdSet+import           Hunt.Common.IntermediateValue+import           Hunt.Index+import qualified Hunt.Index                as Ix+import           Hunt.Index.Proxy.KeyIndex++import qualified Hunt.Index.Schema.Normalize.Position as Pos++import           Hunt.Utility++-- ------------------------------------------------------------++-- | Text index using 'DocIdMap' based on the 'StringMap' implementation.+--   Note that the value parameter is on the type of the 'DocIdMap' value and not the 'DocIdSet'+--   itself.+newtype DmPrefixTree v+  = DmPT { dmPT :: SM.StringMap v }+  deriving (Eq, Show, NFData, Typeable)++mkDmPT :: NFData v => SM.StringMap v -> DmPrefixTree v+mkDmPT v = DmPT $! v++-- ------------------------------------------------------------++instance IndexValue v => Binary (DmPrefixTree v) where+  put = put . dmPT+  get = get >>= return . mkDmPT++-- ------------------------------------------------------------++instance IndexValue v => Index (DmPrefixTree v) where+  type IKey (DmPrefixTree v) = SM.Key+  type IVal (DmPrefixTree v) = v++  insertList kvs (DmPT pt) =+    mkDmPT $ SM.unionWith mergeValues pt (SM.fromList . fromIntermediates $ kvs)++  deleteDocs ks (DmPT pt)+    = mkDmPT $ SM.mapMaybe (diffValues ks) pt++  empty+    = mkDmPT $ SM.empty++  fromList+    = mkDmPT . SM.fromList . fromIntermediates++  toList (DmPT pt)+    = toIntermediates . SM.toList $ pt++  search t k (DmPT pt)+    = toIntermediates $ case t of+        Case         -> case SM.lookup k pt of+                          Nothing -> []+                          Just xs -> [(k,xs)]+        NoCase       -> luCase k pt+        PrefixCase   -> pfCase k pt+        PrefixNoCase -> pfNoCase k pt+    where+    toL      = SM.toListShortestFirst+    luCase   = toL .:: SM.lookupNoCase+    pfCase   = toL .:: SM.prefixFilter+    pfNoCase = toL .:: SM.prefixFilterNoCase++  lookupRange k1 k2 (DmPT pt)+    = toIntermediates . SM.toList $ SM2.lookupRange k1 k2 pt++  unionWith op (DmPT pt1) (DmPT pt2)+    = mkDmPT $ SM.unionWith op pt1 pt2++{-+  unionWithConv to f (DmPT i1) (DmPT i2)+    = liftM mkDmPT $ unionWithConv to f i1 i2+-}++  map f (DmPT pt)+    = mkDmPT $ SM.map f pt++  mapMaybe f (DmPT pt)+    = mkDmPT $ SM.mapMaybe f pt++  keys (DmPT pt)+    = SM.keys pt++-- ------------------------------------------------------------+-- Inverted index using position proxy for geo coordinates+-- ------------------------------------------------------------++-- | Newtype to allow position normalization 'Bijection' instance.+newtype UnPos = UnPos { unPos :: Text }+  deriving (Show, Eq, NFData)++instance Bijection UnPos Text where+  to   = Pos.denormalize . unPos+  from = UnPos . Pos.normalize++instance Bijection Text UnPos where+  to   = UnPos+  from = unPos++-- ------------------------------------------------------------++-- ------------------------------------------------------------++-- | Geo-position index using a 'StringMap'-implementation.+--+newtype PrefixTreeIndexPosition+  = InvPosIx { invPosIx :: KeyProxyIndex Text (KeyProxyIndex UnPos (KeyProxyIndex Text (DmPrefixTree DocIdSet))) }+  deriving (Eq, Show, NFData, Typeable)++mkInvPosIx :: KeyProxyIndex Text (KeyProxyIndex UnPos (KeyProxyIndex Text (DmPrefixTree DocIdSet))) -> PrefixTreeIndexPosition+mkInvPosIx x = InvPosIx $! x++-- ------------------------------------------------------------++instance  Binary PrefixTreeIndexPosition where+  put = put . invPosIx+  get = get >>= return . mkInvPosIx++-- ------------------------------------------------------------++instance Index PrefixTreeIndexPosition where+  type IKey PrefixTreeIndexPosition = Word+  type IVal PrefixTreeIndexPosition = DocIdSet++  insertList wos (InvPosIx i)+    = mkInvPosIx $ insertList wos i++  deleteDocs docIds (InvPosIx i)+    = mkInvPosIx $ deleteDocs docIds i++  empty+    = mkInvPosIx $ Ix.empty++  fromList l+    = mkInvPosIx $ Ix.fromList l++  toList (InvPosIx i)+    = Ix.toList i++  search t k (InvPosIx i)+    = search t k i++  lookupRange k1 k2 (InvPosIx i)+    = lookupRange k1 k2 i++  unionWith op (InvPosIx i1) (InvPosIx i2)+    = mkInvPosIx $ unionWith op i1 i2++--  unionWithConv to' f (InvPosIx i1) (InvPosIx i2)+--    = mkInvPosIx $ unionWithConv to' f i1 i2++  map f (InvPosIx i)+    = mkInvPosIx $ Ix.map f i++  mapMaybe f (InvPosIx i)+    = mkInvPosIx $ Ix.mapMaybe f i++  keys (InvPosIx i)+    = keys i+
+ src/Hunt/Index/Proxy/KeyIndex.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverlappingInstances       #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}++-- ----------------------------------------------------------------------------++{- |+  Key conversion proxy.+  Wraps an index to expose the desired key type.+  The conversion is defined by the 'Bijection' implementation.++  This can be used for simple conversions like @Text@ to @String@ or normalization and compression.+-}++-- ----------------------------------------------------------------------------++module Hunt.Index.Proxy.KeyIndex+( KeyProxyIndex (..)+)+where++import           Prelude                       as P++import           Control.Applicative           ((<$>))+import           Control.Arrow                 (first)+import           Control.DeepSeq++import           Data.Bijection+import           Data.Binary                   (Binary (..))++import           Hunt.Index+import qualified Hunt.Index                    as Ix+import           Hunt.Common.IntermediateValue (IndexValue)+-- ------------------------------------------------------------++-- | Key conversion proxy.+--   @toType@ is the desired/exposed key type, followed by the wrapped index type.+--   There has to be a corresponding 'Bijection' instance:+--+--   >  instance Bijection (IKey impl v) toType where ...+newtype KeyProxyIndex toType impl+  = KeyProxyIx { keyProxyIx :: impl }+  deriving (Eq, Show, NFData)++-- | Wrap an index in a key conversion proxy.+mkKeyProxyIx :: impl -> KeyProxyIndex toType impl+mkKeyProxyIx v = KeyProxyIx $! v++-- ------------------------------------------------------------++instance Binary (impl) => Binary (KeyProxyIndex toType impl) where+  put = put . keyProxyIx+  get = get >>= return . mkKeyProxyIx++-- ------------------------------------------------------------++instance (IndexValue (IVal impl)) => Index (KeyProxyIndex toType impl) where+  type IKey      (KeyProxyIndex toType impl) = toType+  type IVal      (KeyProxyIndex toType impl) = IVal impl+  type ICon      (KeyProxyIndex toType impl) = ( Index impl+                                               , ICon impl+                                               , Bijection (IKey impl) toType+                                               )++  insertList kvs (KeyProxyIx i)+    = mkKeyProxyIx $ insertList (P.map (first from) kvs) i++  deleteDocs ks (KeyProxyIx i)+    = mkKeyProxyIx $ deleteDocs ks i++  empty+    = mkKeyProxyIx $ empty++  fromList l+    = mkKeyProxyIx . fromList $ P.map (first from) l++  toList (KeyProxyIx i)+    = first to <$> toList i++  search t k (KeyProxyIx i)+    = first to <$> search t (from k) i++  lookupRange k1 k2 (KeyProxyIx i)+    = first to <$> lookupRange (from k1) (from k2) i++  unionWith op (KeyProxyIx i1) (KeyProxyIx i2)+    = mkKeyProxyIx $ unionWith op i1 i2++--  unionWithConv t f (KeyProxyIx i1) (KeyProxyIx i2)+--    = mkKeyProxyIx $ unionWithConv t f i1 i2++  map f (KeyProxyIx i)+    = mkKeyProxyIx $ Ix.map f i++  mapMaybe f (KeyProxyIx i)+    = mkKeyProxyIx $ Ix.mapMaybe f i++  keys (KeyProxyIx i)+    = P.map to $ keys i
+ src/Hunt/Index/RTreeIndex.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies               #-}++-- ----------------------------------------------------------------------------+{- |+  Text index using the 'DocIdMap' based on the 'StringMap' implementation.+-}+-- ----------------------------------------------------------------------------++module Hunt.Index.RTreeIndex+(   RTreeIndex(..)+  , SimpleRTreeIndex(..)+  , readPosition+  , showPosition+)+where++import           Control.DeepSeq++import           Data.Binary                          (Binary (..))+import qualified Data.List                            as L+import           Data.Monoid                          ((<>))+import qualified Data.RTree.Strict                    as RT+import           Data.RTree.MBB+import           Data.Text                            (Text)+import qualified Data.Text                            as T (pack, unpack)+import           Data.Typeable+import           Data.Bijection++import           Hunt.Index+import qualified Hunt.Index                           as Ix+import           Hunt.Index.Proxy.KeyIndex+import           Hunt.Common.IntermediateValue+import           Hunt.Common.DocIdSet                 (DocIdSet)+import           Hunt.Index.Schema.Normalize.Position (position)++import           Text.Parsec+++-- ------------------------------------------------------------++-- | Index adapter for 'Data.RTree' data structure++newtype RTreeIndex v+  = DmRT { dmRT :: RT.RTree v }+  deriving (Eq, Show, NFData, Typeable)++mkDmRT :: RT.RTree v -> RTreeIndex v+mkDmRT v = DmRT $! v++-- ------------------------------------------------------------++instance IndexValue x => Binary (RTreeIndex x) where+  put = put . dmRT+  get = get >>= return . mkDmRT++-- ------------------------------------------------------------++instance IndexValue v => Index (RTreeIndex v) where+  type IKey (RTreeIndex v) = RT.MBB+  type IVal (RTreeIndex v) = v++  insertList kvs (DmRT rt) =+    mkDmRT $ L.foldl' (\ m' (k', v') -> RT.insertWith mergeValues k' v' m') rt (fromIntermediates kvs)++    {- same problem as in PrefixTreeIndex, the k' in kvs don't need to be unique++       mkDmRT $ RT.unionWith op rt (RT.fromList kvs)+    -}++  deleteDocs ks (DmRT rt)+    = mkDmRT $ RT.mapMaybe (diffValues ks) rt++  empty+    = mkDmRT $ RT.empty++  fromList+    = mkDmRT . RT.fromList . fromIntermediates++  toList (DmRT rt)+    = toIntermediates . RT.toList $ rt++  -- MBBs don't have any case or prefix+  search _ k (DmRT rt)+    = toIntermediates $ RT.lookupRangeWithKey k rt++  lookupRange k1 k2 (DmRT rt)+    = toIntermediates $ RT.lookupRangeWithKey (unionMBB k1 k2) rt++  unionWith op (DmRT rt1) (DmRT rt2)+    = mkDmRT $ RT.unionWith op rt1 rt2++  map f (DmRT rt)+    = mkDmRT $ fmap f rt++  -- prohibitiv expensive.+  mapMaybe f (DmRT rt)+    = mkDmRT $ RT.mapMaybe f rt++  keys (DmRT rt)+    = RT.keys rt++-- ------------------------------------------------------------++readPosition :: Text -> MBB+readPosition t+  = case parse position "" $ T.unpack t of+     Right (la,lo) -> mbb la lo la lo+     Left _        -> error "readPosition positon: invalid"++showPosition :: MBB -> Text+showPosition (MBB la lo _ _ ) = T.pack (show la) <> "-" <> T.pack (show lo)++-- ------------------------------------------------------------+-- Index using RTree for indexing positions and bounding boxes+-- ------------------------------------------------------------++-- | Newtype to allow date normalization 'Bijection' instance.++instance Bijection MBB Text where+  to   = showPosition+  from = readPosition++-- ------------------------------------------------------------++-- | Date index using a 'StringMap'-implementation.+newtype SimpleRTreeIndex+  = InvRTreeIx { invRTreeIx :: KeyProxyIndex Text (RTreeIndex DocIdSet)}+  deriving (Eq, Show, NFData, Typeable)++mkInvRTreeIx :: KeyProxyIndex Text (RTreeIndex DocIdSet) -> SimpleRTreeIndex+mkInvRTreeIx x = InvRTreeIx $! x++-- ------------------------------------------------------------++instance Binary SimpleRTreeIndex where+  put = put . invRTreeIx+  get = get >>= return . mkInvRTreeIx++-- ------------------------------------------------------------++instance Index SimpleRTreeIndex where+  type IKey SimpleRTreeIndex = Text+  type IVal SimpleRTreeIndex = DocIdSet++  insertList wos (InvRTreeIx i)+    = mkInvRTreeIx $ insertList wos i++  deleteDocs docIds (InvRTreeIx i)+    = mkInvRTreeIx $ deleteDocs docIds i++  empty+    = mkInvRTreeIx $ empty++  fromList l+    = mkInvRTreeIx $ fromList l++  toList (InvRTreeIx i)+    = toList i++  search t k (InvRTreeIx i)+    = search t k i++  lookupRange k1 k2 (InvRTreeIx i)+    = lookupRange k1 k2 i++  unionWith op (InvRTreeIx i1) (InvRTreeIx i2)+    = mkInvRTreeIx $ unionWith op i1 i2++  map f (InvRTreeIx i)+    = mkInvRTreeIx $ Ix.map f i++  mapMaybe f (InvRTreeIx i)+    = mkInvRTreeIx $ Ix.mapMaybe f i++  keys (InvRTreeIx i)+    = keys i++
+ src/Hunt/Index/Schema.hs view
@@ -0,0 +1,326 @@+{-# OPTIONS -fno-warn-orphans  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++-- ----------------------------------------------------------------------------+{- |+  Schema for the 'ContextIndex'.++  Every context has a type (e.g. text, int, date, position) and additional schema information.+  This includes how keys are splitted and normalized when inserted and searched for.+-}+-- ----------------------------------------------------------------------------++module Hunt.Index.Schema+  (+    -- * Types+    Schema+  , ContextSchema (..)+  , ContextType (..)+  , ContextTypes+  , CValidator (..)+  , CNormalizer (..)+  , normalize'++    -- * Default Context Types+  , ctText+  , ctTextSimple+  , ctInt+  , ctDate+  , ctPosition+  , ctPositionRTree++  -- * Default Normalizers+  , cnUpperCase+  , cnLowerCase+  , cnZeroFill+  )+where++import           Control.Applicative+import           Control.Monad                        (mzero)++import           Data.Aeson+import           Data.Binary                          hiding (Word)+import           Data.Default+import qualified Data.List                            as L+import           Data.Map                             hiding (null)+import           Data.Maybe                           (isNothing)+import           Data.Text                            hiding (null)+import qualified Data.Text                            as T+import           Data.Text.Binary                     ()++import           Hunt.Common.BasicTypes+import qualified Hunt.Index                           as Ix+import           Hunt.Index.IndexImpl                 (IndexImpl, mkIndex)+import           Hunt.Index.InvertedIndex+import           Hunt.Index.PrefixTreeIndex           ( PrefixTreeIndexInt+                                                      , PrefixTreeIndexDate+                                                      , SimplePrefixTreeIndex )+import           Hunt.Index.PrefixTreeIndex2Dim       ( PrefixTreeIndexPosition )++import           Hunt.Index.RTreeIndex++import qualified Hunt.Index.Schema.Normalize.Date     as Date+import qualified Hunt.Index.Schema.Normalize.Int      as Int+import qualified Hunt.Index.Schema.Normalize.Position as Pos+import           Hunt.Utility++-- ------------------------------------------------------------++-- | The global schema assigning schema information to each context.+type Schema+  = Map Context ContextSchema++-- | The context schema information. Every context schema has a type and additional to adjust the+--   behavior.+--+--   The regular expression splits the text into words which are then transformed by the given+--   normalizations functions (e.g. to lower case).++data ContextSchema = ContextSchema+  {+    -- | Optional regex to override the default given by context type.+    cxRegEx      :: Maybe RegEx+    -- | Normalizers to apply on keys.+  , cxNormalizer :: [CNormalizer]+    -- | Context weight to boost results.+  , cxWeight     :: Weight+    -- | Whether the context is searched in queries without context-specifier.+  , cxDefault    :: Bool+    -- | The type of the index (e.g. text, int, date, geo-position).+  , cxType       :: ContextType+  }+  deriving Show++-- ------------------------------------------------------------++instance Default ContextSchema where+  def = ContextSchema Nothing [] 1.0 True def++-- ------------------------------------------------------------++-- | Set of context types.+type ContextTypes = [ContextType]++-- | A general context type like text or int.+data ContextType = CType+  {+    -- | Name used in the (JSON) API.+    ctName     :: Text+    -- | Default regex to split words.+  , ctRegEx    :: RegEx+    -- | Validation function for keys.+  , ctValidate :: CValidator+    -- | The index implementation used for this type.+  , ctIxImpl   :: IndexImpl+  }+  deriving Show++-- ------------------------------------------------------------++instance Default ContextType where+  def = ctText++-- ------------------------------------------------------------++-- | Text context type.+ctText :: ContextType+ctText = CType+  { ctName     = "text"+  , ctRegEx    = "\\w*"+  , ctValidate = def+  , ctIxImpl   = def+  }++-- | Special text context type+--   smaller index but not phrase queries possible+--   (due to not storing the words positions)+ctTextSimple :: ContextType+ctTextSimple = CType+  { ctName     = "text-small"+  , ctRegEx    = "\\w*"+  , ctValidate = def+  , ctIxImpl   = simplePT+  }++-- | Int context type.+ctInt :: ContextType+ctInt = CType+  { ctName     = "int"+  , ctRegEx    = "([-]?[0-9]*)"+  , ctValidate = CValidator $ Int.isInt+  , ctIxImpl   = intInv+  }++-- | Date context type.+ctDate :: ContextType+ctDate = CType+  { ctName     = "date"+  , ctRegEx    = "[0-9]{4}-((0[1-9])|(1[0-2]))-((0[1-9])|([12][0-9])|(3[01]))"+  , ctValidate = CValidator $ Date.isAnyDate . unpack+  , ctIxImpl   = dateInv+  }++-- | Geographic position context type.+ctPosition :: ContextType+ctPosition = CType+  { ctName     = "position"+  , ctRegEx    = "-?(90(\\.0*)?|[1-8]?[0-9](\\.[0-9]*)?)--?((180(\\.0*)?)|(1[0-7][0-9])|([1-9]?[0-9]))(\\.[0-9]*)?"+  , ctValidate = CValidator $ Pos.isPosition+  , ctIxImpl   = positionInv+  }++ctPositionRTree :: ContextType+ctPositionRTree = CType+  { ctName     = "position-rtree"+  , ctRegEx    = "-?(90(\\.0*)?|[1-8]?[0-9](\\.[0-9]*)?)--?((180(\\.0*)?)|(1[0-7][0-9])|([1-9]?[0-9]))(\\.[0-9]*)?"+  , ctValidate = CValidator $ Pos.isPosition+  , ctIxImpl   = positionRTree+  }+++-- ------------------------------------------------------------+-- IndexImpls+-- ------------------------------------------------------------++instance Default IndexImpl where+  def = defaultInv++-- ------------------------------------------------------------++-- | Default (text) index implementation.+defaultInv :: IndexImpl+defaultInv = mkIndex (Ix.empty :: InvertedIndex)++-- | Simpler (text) index, which still enables prefix search,+--   but not phrase search anymore. Useful for cases where+--   word positions are not relevant+simplePT :: IndexImpl+simplePT = mkIndex (Ix.empty :: SimplePrefixTreeIndex)++-- | Int index implementation.+intInv :: IndexImpl+intInv = mkIndex (Ix.empty :: PrefixTreeIndexInt)++-- | Date index implementation.+dateInv :: IndexImpl+dateInv = mkIndex (Ix.empty :: PrefixTreeIndexDate)++-- | Geographic position index implementation based on 'StringMap'+positionInv :: IndexImpl+positionInv = mkIndex (Ix.empty :: PrefixTreeIndexPosition)++-- | Geographic position index implementation based on 'RTree'+positionRTree :: IndexImpl+positionRTree = mkIndex (Ix.empty :: SimpleRTreeIndex)+++-- ------------------------------------------------------------+-- Validator+-- ------------------------------------------------------------++-- | Validation function for single words.+data CValidator = CValidator { validate :: Word -> Bool }++-- ------------------------------------------------------------++instance Default CValidator where+  def = CValidator $ const True++-- XXX: maybe add name to validator type as well+instance Show CValidator where+  show _ = "CValidator"++-- ------------------------------------------------------------+-- Normalizer+-- ------------------------------------------------------------++-- | Normalizer for words\/keys of an index.+data CNormalizer = CNormalizer+  { cnName    :: Text         -- ^ Name used in (JSON) API.+  , normalize :: Text -> Text -- ^ Normalization function.+  }++-- | Apply the normalizers to a word.+normalize' :: [CNormalizer] -> Word -> Word+normalize' ns  = L.foldl' (\f2 (CNormalizer _ f1) -> f1 . f2) id $ ns++-- ------------------------------------------------------------++instance Show CNormalizer where+  show = unpack . cnName++instance Default CNormalizer where+  def = CNormalizer "" id++-- | Uppercase normalizer \"UpperCase\".+cnUpperCase :: CNormalizer+cnUpperCase = CNormalizer "UpperCase" T.toUpper++-- | Lowercase normalizer \"LowerCase\".+cnLowerCase :: CNormalizer+cnLowerCase = CNormalizer "LowerCase" T.toLower++-- | Int normalizer \"ZeroFill\" to preserve int ordering on strings.+cnZeroFill :: CNormalizer+cnZeroFill = CNormalizer "ZeroFill" Int.normalizeToText++-- ------------------------------------------------------------+-- JSON instances+-- ------------------------------------------------------------++-- | /Note/: This is only partial (de-)serialization.+--   The other components are environment-dependent+--   and cannot be (de-)serialized. We serialize the name+--   and identify the other compontens of the type later.++instance FromJSON ContextType where+  parseJSON (String s) = return $ def { ctName = s }+  parseJSON _          = mzero++instance ToJSON ContextType where+  toJSON (CType n _ _ _) = String n++instance FromJSON CNormalizer where+  parseJSON (String s) = return $ def { cnName = s }+  parseJSON _          = mzero++instance ToJSON CNormalizer where+  toJSON (CNormalizer n _) = String n++instance FromJSON ContextSchema where+  parseJSON (Object o) = do+    r  <- o .:? "regexp"+    n  <- o .:? "normalizers" .!= []+    w  <- o .:? "weight"      .!= 1.0+    d  <- o .:? "default"     .!= True+    ct <- o .:  "type"+    return $ ContextSchema r n w d ct++  parseJSON _ = mzero++instance ToJSON ContextSchema where+  toJSON (ContextSchema r n w d ct) = object' $+    [ "type"        .== ct+    , "weight"      .=? w .\. (== 1.0)+    , "regexp"      .=? r .\. isNothing+    , "normalizers" .=? n .\. null+    , "default"     .=? d .\. id+    ]++-- ------------------------------------------------------------+-- Binary instances+-- ------------------------------------------------------------++instance Binary ContextSchema where+  get = ContextSchema <$> get <*> get <*> get <*> get <*> get+  put (ContextSchema a b c d e) = put a >> put b >> put c >> put d >> put e++instance Binary ContextType where+  put (CType n _ _ _) = put n+  get = get >>= \n -> return $ def { ctName = n }++instance Binary CNormalizer where+  put (CNormalizer n _) = put n+  get = get >>= \n -> return $ def { cnName = n }
+ src/Hunt/Index/Schema/Analyze.hs view
@@ -0,0 +1,99 @@+-- ----------------------------------------------------------------------------+{- |+  Analyzer for index data.+  Creates raw index data by splitting and normalizing the 'ApiDocument' index data as defined in+  the schema.+-}+-- ----------------------------------------------------------------------------++module Hunt.Index.Schema.Analyze+  ( toDocAndWords+  , toDocAndWords'+  , normalize+  , scanTextRE+  )+where++import           Data.DList                  (DList)+import qualified Data.DList                  as DL+import           Data.Map                    (Map)+import qualified Data.Map                    as M+import           Data.Maybe                  (fromJust, fromMaybe)+import           Data.Text                   (Text)+import qualified Data.Text                   as T++import           Text.Regex.XMLSchema.String++import           Hunt.Common.ApiDocument+import           Hunt.Common.BasicTypes+import           Hunt.Common.Document        (Document (..),+                                              DocumentWrapper (..))+import           Hunt.Index.Schema++-- ------------------------------------------------------------++-- | Extracts the 'Document' ('DocumentWrapper') and raw index data from an 'ApiDocument' in+--   compliance with the schema.+--+--   /Note/: Contexts mentioned in the 'ApiDocument' need to exist.++toDocAndWords :: DocumentWrapper e => Schema -> ApiDocument -> (e, Score, Words)+toDocAndWords s+    = ( \ (d, dw, ws) -> (wrap d, dw, ws) )+      . toDocAndWords' s++-- | Extracts the 'Document' and raw index data from an 'ApiDocument' in compliance with the schema.+--+--   /Note/: Contexts mentioned in the ApiDoc need to exist.++toDocAndWords' :: Schema -> ApiDocument -> (Document, Score, Words)+toDocAndWords' schema apiDoc+    = (doc, weight, ws)+    where+      indexMap = adIndex apiDoc+      descrMap = adDescr apiDoc+      weight   = adWght  apiDoc+      doc = Document+            { uri   = adUri apiDoc+            , desc  = descrMap+            , wght  = toDefScore weight+            }+      ws = M.mapWithKey+           ( \ context content ->+                 let (ContextSchema rex normalizers _ _ cType)+                         = fromJust $ M.lookup context schema+                     (CType _ defRex validator _)+                         = cType+                     scan+                         = filter (validate validator) . scanTextRE (fromMaybe defRex rex)+                 in+                   toWordList scan (normalize' normalizers) content+           )+           indexMap++-- | Construct a 'WordList' from text using the splitting and normalization function.++toWordList :: (Text -> [Word]) -> (Word -> Word) -> Text -> WordList+toWordList scan norm+    = M.map DL.toList+      . foldr insert M.empty+      . zip [1..]+      . map norm+      . scan+    where+      insert :: (Position, Word) -> Map Word (DList Position) -> Map Word (DList Position)+      insert (p, w)+          = M.alter (return . maybe (DL.singleton p) (`DL.snoc` p)) w++-- | Tokenize a text with a regular expression for words.+--+--  > scanTextRE "[^ \t\n\r]*" == Data.Text.words+--+--   Grammar: <http://www.w3.org/TR/xmlschema11-2/#regexs>+scanTextRE :: RegEx -> Text -> [Word]+scanTextRE wRex+    = map T.pack+      . tokenize (T.unpack wRex)+      . T.unpack++-- ------------------------------------------------------------
+ src/Hunt/Index/Schema/Normalize/Date.hs view
@@ -0,0 +1,433 @@+{-# LANGUAGE OverloadedStrings #-}++-- ----------------------------------------------------------------------------++{- |+  Normalization and validation for date.++  Days are represented here as in ISO 8601:2000 Second Edition:+      ISO (International Organization for Standardization).+      Representations of dates and times, second edition, 2000-12-15.++   NOT as in+   ISO 8601+      ISO (International Organization for Standardization).+      Representations of dates and times, 1988-06-15.++   The main difference is dealing with year 0.+   in the older ISO standard, this is excluded and+   "-0001" is the representation of year 1 Before Common Era "-1 BCE".+   In the latter standard "0000" represents "-1 BCE" and "-0001" represents "-2 BCE"+-}+-- source hxt-xmlschema/src/Text/XML/HXT/XMLSchema/W3CDataTypeCheck.hs++-- ----------------------------------------------------------------------------++module Hunt.Index.Schema.Normalize.Date+  ( normalize, denormalize+  , isAnyDate+  , isAnyDate'+  , isTime+  , nullDay+  , showGYearMonth+  , showGYear+  , showGMonthDay+  , showGMonth+  , showGDay+  , showTime+  )+where++import           Control.Applicative+import           Control.Monad++import           Data.List+import           Data.Maybe+import           Data.Text                   (Text)+import qualified Data.Text                   as T++import           Data.Char                   (isDigit)+import           Data.Function               (on)+import           Data.Ratio                  ((%))+import           Data.Time                   (Day, DiffTime, UTCTime (..),+                                              addUTCTime, fromGregorian)++import           Text.Regex.XMLSchema.String++import           Hunt.Utility++-- ------------------------------------------------------------++-- | Normalize a date representation to store in the index or search for.+normalize :: Text -> Text+normalize t = fromMaybe t+    (T.pack . normDateRep . showDateTime . toUTC <$> (readAnyDateM . T.unpack $ t))+  where+  -- XXX: no proper support for dates before year 0 (1 BCE) this way+  normDateRep :: String -> String+  normDateRep s+    = if head' s == Just '-'+      then ('-':) . fil . tail $ s+      else fil s+    where fil = filter (not . (`elem` "-T:"))++-- | Function takes normalized Date and transforms it back a readable form.+--   We don't transform it back to the original representation, since that+--   is never used, but to a general readable date format+denormalize :: Text -> Text+denormalize t = T.concat [y1, y2, "-", m, "-", d, " ", h, ":", i, ":", s]+  where+  [y1,y2,m,d,h,i,s] = T.chunksOf 2 t++-- ------------------------------------------------------------++-- | Checks if the string is a date representation (syntactically).+isAnyDate :: String -> Bool+isAnyDate s = any ($ s) $ map fst safeDateReaders++-- XXX: generally (showDate . readAnyDate) /= id+-- | Same as 'isAnyDate' but also checks if @(showDate . readAnyDate)@ produces the same result.+--   /NOTE/: excludes dates before year 0 (1 BCE).+isAnyDate' :: String -> Bool+isAnyDate' s = fromMaybe False $ do+  d <- readAnyDateM s+  guard $ ((==s) . showDate . readAnyDate) s+  return . not . isPrefixOf "-" . showDate . toUTC $ d++-- | Unsafe 'readAnyDateM'.+readAnyDate :: String -> Date+readAnyDate = fromJust . readAnyDateM++-- | Try to read a date.+readAnyDateM :: String -> Maybe Date+readAnyDateM s = head' . catMaybes . map readDateM $ safeDateReaders+  where+  readDateM :: (String -> Bool, String -> Date) -> Maybe Date+  readDateM (v, r) = guard (v s) >> return (r s)++-- | Tuples of date validator and reader.+safeDateReaders :: [(String -> Bool, String -> Date)]+safeDateReaders = zip validators readers+  where+  validators :: [String -> Bool]+  validators = [  isDateTime,   isDate,   isGYearMonth,   isGYear,   isGMonthDay,   isGMonth,   isGDay]+  readers    :: [String -> Date]+  readers    = [readDateTime, readDate, readGYearMonth, readGYear, readGMonthDay, readGMonth, readGDay]++-- ------------------------------------------------------------++-- source hxt-xmlschema/src/Text/XML/HXT/XMLSchema/W3CDataTypeCheck.hs++-- ----------------------------------------+--+-- Days are represented here+-- as in ISO 8601:2000 Second Edition:+--    ISO (International Organization for Standardization).+--    Representations of dates and times, second edition, 2000-12-15.+--+-- NOT as in+-- ISO 8601+--    ISO (International Organization for Standardization).+--    Representations of dates and times, 1988-06-15.+--+-- The main difference is dealing with year 0.+-- in the older ISO standard, this is excluded and+-- "-0001" is the representation of year 1 Before Common Era "-1 BCE".+-- In the latter standard "0000" represents "-1 BCE" and "-0001" represents "-2 BCE"++data Date =+    Date { _dUTCTime :: UTCTime+         , _dTZ      :: MaybeTimeZone+         }+    deriving (Show)++type MaybeTimeZone = Maybe Seconds++type Seconds = Int++instance Eq Date where+    (==) = (==) `on` toUTCTime++instance Ord Date where+    compare = compare `on` toUTCTime++mkDateTime :: Day -> DiffTime -> MaybeTimeZone -> Date+mkDateTime d t z+    = Date (UTCTime d t) z++toUTCTime :: Date -> UTCTime+toUTCTime (Date d Nothing) = d+toUTCTime (Date d (Just tz)) = addUTCTime (fromInteger . toInteger $ tz) d++-- | Convert to UTC time. Eliminates the timezone offset.+toUTC :: Date -> Date+toUTC d = Date (toUTCTime d) Nothing -- to UTC++-- ------------------------------------------------------------++isDateTime, isDate, isTime, isGYearMonth, isGYear, isGMonthDay, isGMonth, isGDay :: String -> Bool+[isDateTime, isDate, isTime, isGYearMonth, isGYear, isGMonthDay, isGMonth, isGDay]+    = map matchRE rexDates+++rexDates :: [Regex]+rexDates+    = map rex [dateTime, date, time, gYearMonth, gYear, gMonthDay, gMonth, gDay]+    where+      dateTime   = ymd ++ "T" ++ hms ++ tz+      time       =               hms ++ tz+      date       = ymd               ++ tz+      gYearMonth = ym                ++ tz+      gYear      = y                 ++ tz++      gMonthDay  = "--" ++ m2 ++ "-" ++ t2 ++ tz+      gMonth     = "--" ++ m2              ++ tz+      gDay       = "--"       ++ "-" ++ t2 ++ tz++      y     = "-?" ++ y4'+      ym    = y           ++ "-" ++ m2+      ymd   = ym                       ++ "-" ++ t2++      hms   = alt (h2 ++ ":" ++ i2 ++ ":" ++ s2 ++ fr)+                  ("24:00:00" ++ opt ".0+")             -- 24:00 is legal++      tz    = opt (alt tz0 "Z")+      tz0   = (alt "\\-" "\\+") ++ tz1+      tz1   = alt (h13 ++ ":" ++ i2) "14:00:00"++      m2    = alt "0[1-9]" "1[0-2]"                     -- Month+      t2    = alt "0[1-9]" (alt "[12][0-9]" "3[01]")    -- Tag+      h2    = alt "[01][0-9]" "2[0-3]"                  -- Hour+      i2    = "[0-5][0-9]"                              -- mInute+      s2    = i2                                        -- Seconds++{-                                                      -- this conforms to ISO 8601 from 1988+      y1    = "000[1-9]"                                -- "0000" isn't a year, "-0001" represents "-1 BCE"+      y2    = "00[1-9][0-9]"                            -- leading 0-s are only allowd for year < 1000+      y3    = "0[1-9][0-9]{2}"+      y4    = "[1-9][0-9]{3,}"+      y4'   = alt y4 $ alt y3 $ alt y2 y1+-- -}++-- {-                                                   -- this conforms to ISO 8601 Second Edition from 2000+      y4    = "[0-9]{4}"                                -- year "0000" is legal and represents "-1 BCE"+      y4'   = opt "[1-9][0-9]*" ++ y4+-- -}++      fr    = opt ".[0-9]+"++      h13   = alt "0[0-9]" "1[0-3]"++      opt x     = "(" ++ x ++ ")?"+      alt x1 x2 = "((" ++ x1 ++ ")|(" ++ x2 ++ "))"+++-- ------------------------------------------------------------++readDate+  , readGYearMonth+  , readGYear+  , readGMonthDay+  , readGMonth+  , readGDay :: String -> Date++readDate       = readDate' readYearMonthDayS+readGYearMonth = readDate' readYearMonthS+readGYear      = readDate' readYearS+readGMonthDay  = readDate' readMonthDayS+readGMonth     = readDate' readMonthS+readGDay       = readDate' readDayS+++readTimeZone :: String -> MaybeTimeZone+readTimeZone ""+    = Nothing+readTimeZone "Z"+    = Just 0+readTimeZone (s : xs)+    = Just .+      ( if s == '-' then negate else id ) .+      readZone $ xs+    where+      readZone s'+          = 60 * (60 * read hs + read ms)+          where+            (hs, (_ : ms)) = span (/= ':') s'++readYearMonthDayS :: String -> (Day, String)+readYearMonthDayS s0+    = (fromGregorian (sign $ read year) (read month) (read day), rest)+    where+      (sign,          s ) = if head s0 == '-'+                            then (negate, tail s0)+                            else (id,          s0)+      (year,  (_ : rest1)) = span (/= '-') s+      (month, (_ : rest2)) = span (/= '-') rest1+      (day,        rest  ) = span isDigit rest2++readYearMonthS :: String -> (Day, String)+readYearMonthS s0+    = (fromGregorian (sign $ read year) (read month) 1, rest)+    where+      (sign,          s ) = if head s0 == '-'+                            then (negate, tail s0)+                            else (id,          s0)+      (year,  (_ : rest1)) = span (/= '-') s+      (month,      rest  ) = span isDigit rest1++readYearS :: String -> (Day, String)+readYearS s0+    = (fromGregorian (sign $ read year) 1 1, rest)+    where+      (sign,          s ) = if head s0 == '-'+                            then (negate, tail s0)+                            else (id,          s0)+      (year,       rest  ) = span isDigit s++readMonthDayS :: String -> (Day, String)+readMonthDayS s0+    = (fromGregorian 1 (read month) (read day), rest)+    where+      (month, (_ : rest1)) = span isDigit . drop 2 $ s0+      (day,        rest  ) = span isDigit rest1++readMonthS :: String -> (Day, String)+readMonthS s0+    = (fromGregorian 1 (read month) 1, rest)+    where+      (month,       rest ) = span isDigit . drop 2 $ s0++readDayS :: String -> (Day, String)+readDayS s0+    = (fromGregorian 1 1 (read day), rest)+    where+      (day,         rest ) = span isDigit . drop 3 $ s0++readHourMinSec :: String -> DiffTime+readHourMinSec s+    = fromInteger (60 * (60 * read hours + read minutes))+      ++      fromRational (readDecimal seconds)+    where+      (hours,   (_ :    rest)) = span (/= ':') s+      (minutes, (_ : seconds)) = span (/= ':') rest++readDateTime :: String -> Date+readDateTime s+    = mkDateTime day (readHourMinSec time) (readTimeZone zone)+    where+      (day,  (_ : rest)) = readYearMonthDayS s+      (time,       zone) = span (\ x -> isDigit x || x `elem` ":.") rest+++readDate' :: (String -> (Day, String)) -> String -> Date+readDate' read' s+    = mkDateTime day nullTime (readTimeZone zone)+    where+      (day, zone) = read' s++nullTime :: DiffTime+nullTime = fromInteger 0++nullDay :: Day+nullDay = fromGregorian 1 1 1++-- ----------------------------------------++-- | Reads a decimal from a string++readDecimal :: String -> Rational+readDecimal ('+':s) = readDecimal' s+readDecimal ('-':s) = negate $ readDecimal' s+readDecimal      s  = readDecimal' s++-- | Helper function to read a decimal from a string+readDecimal' :: String -> Rational+readDecimal' s+  | f == 0    = (n % 1)+  | otherwise = (n % 1) + (f % (10 ^ (toInteger $ length fs)))+  where+  (ns, fs') = span (/= '.') s+  fs = drop 1 fs'++  f :: Integer+  f | null fs   = 0+    | otherwise = read fs+  n :: Integer+  n | null ns   = 0+    | otherwise = read ns++-- --------------------+-- the show must go on++showDateTime :: Date -> String+showDateTime (Date d tz)+    = ymd ++ "T" ++ hms ++ showTimeZone tz+    where+      (ymd : hms : _) = words . show $ d++showDate' :: (String -> String) -> Date -> String+showDate' fmt (Date d tz)+    = fmt ymd ++ showTimeZone tz+    where+      (ymd : _) = words . show $ d++dropRev :: Int -> String -> String+dropRev i = reverse . drop i . reverse++showDate :: Date -> String+showDate = showDate' $ id++showGYearMonth :: Date -> String+showGYearMonth = showDate' $ dropRev 3++showGYear :: Date -> String+showGYear = showDate' $ dropRev 6++showGMonthDay :: Date -> String+showGMonthDay = showDate' $ ('-' :) . reverse . take 6 . reverse++showGMonth :: Date -> String+showGMonth = showDate' $ ('-' :) . reverse . take 3 . drop 3 . reverse++showGDay :: Date -> String+showGDay = showDate' $ ('-' :) . ('-' :) . reverse . take 3 . reverse++-- it's+showTime :: Date -> String+showTime (Date d tz)+    = hms ++ showTimeZone tz+    where+      (_ymd : hms : _) = words . show $ d++showTimeZone :: MaybeTimeZone -> String+showTimeZone Nothing+    = ""+showTimeZone (Just s)+    | s == 0    = "Z"+    | s >  0    = '+' : showHourMin s+    | otherwise = '-' : showHourMin (negate s)++showHourMin :: Int -> String+showHourMin s0+    = showDec 2 (s `div` 60) ++ ":" ++ showDec 2 (s `mod` 60)+    where+      s = s0 `div` 60++showDec :: Int -> Int -> String+showDec n = reverse . toStr n+    where+      toStr 0 _ = ""+      toStr l i = show (i `mod` 10) ++ toStr (l-1) (i `div` 10)++-- ------------------------------------------------------------++-- | Creates a regex from a string+rex :: String -> Regex+rex regex+  | isZero ex = error $ "syntax error in regexp " ++ show regex ++ "."+  | otherwise = ex+  where+  ex = parseRegex regex++-- ------------------------------------------------------------
+ src/Hunt/Index/Schema/Normalize/Int.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE OverloadedStrings #-}++-- ----------------------------------------------------------------------------+{- |+  Normalization and validation for integer.+-}+-- ----------------------------------------------------------------------------++module Hunt.Index.Schema.Normalize.Int+  ( normalizeToText, denormalizeFromText+  , normalizeToInt, denormalizeFromInt+  , isInt, integer+  )+where++import           Data.Text                     (Text)+import qualified Data.Text                     as T++import           Control.Applicative           hiding ((<|>))+import           Hunt.Common.BasicTypes+import           Text.ParserCombinators.Parsec++-- ------------------------------------------------------------+-- Normalize Int to actual Int+-- ------------------------------------------------------------++-- | Normalize an integer to an 'Int'.+normalizeToInt :: Text -> Int+normalizeToInt = getInt++-- | Denormalize an integer.+denormalizeFromInt :: Int -> Text+denormalizeFromInt = T.pack . show++-- ------------------------------------------------------------+-- Normalize Int as Text+-- ------------------------------------------------------------++-- | Normalize a /valid/ integer to a 'Text' representation preserving ordering.+normalizeToText' :: Word -> Word+normalizeToText' i+  = T.concat [pfx, zeros, nr]+  where+  (pfx,nr) = if T.take 1 i == "-"+             then ("0", T.drop 1 i)+             else ("1", i)+  elems    = 20 - T.length nr+  zeros    = T.replicate elems "0"++-- | Normalize an integer to a 'Text' representation preserving ordering.+normalizeToText :: Text -> Text+normalizeToText t+  = if isInt t+    then normalizeToText' t+    else error "normalizeToText: invalid input"++-- | Denormalize a value transformed with 'normalize'.+denormalizeFromText :: Text -> Text+denormalizeFromText i+  = sign raw+  where+  sign = if T.take 1 i == "1" then id else ('-' `T.cons`)+  raw  = T.dropWhile (== '0') $ T.drop 1 i++-- ------------------------------------------------------------+-- Validate int+-- ------------------------------------------------------------++-- | Parse a /valid/ integer.+--+--   /Note/: This will fail on invalid integers.+getInt :: Text -> Int+getInt int = case parse integer "" $ T.unpack int of+  Right pint -> pint+  _          -> error "getInt: invalid input"++-- | Validate if the text represents a valid integer.+--   Needs to be within 'Int' range.+isInt :: Text -> Bool+isInt int = case parse integer "" $ T.unpack int of+  Right pint -> int == (T.pack . show $ pint)+  _          -> False++-- | Parse a simple integer representation.+integer :: Parser Int+integer = rd <$> (plus <|> minus <|> number)+  where+  rd     = read :: String -> Int+  plus   = char '+' *> number+  minus  = (:) <$> char '-' <*> number+  number = many1 digit++-- ------------------------------------------------------------
+ src/Hunt/Index/Schema/Normalize/Position.hs view
@@ -0,0 +1,199 @@+-- ----------------------------------------------------------------------------+{- |+  Normalization and validation for geographic positions.+-}+-- ----------------------------------------------------------------------------++module Hunt.Index.Schema.Normalize.Position+  ( normalize, denormalize+  , isPosition, position+  )+where++import           Numeric++import           Control.Applicative           hiding ((<|>))++import           Data.Text                     (Text)+import qualified Data.Text                     as T+++import           Text.Parsec+import           Text.ParserCombinators.Parsec++import           Hunt.Utility++-- ------------------------------------------------------------+-- validator+-- ------------------------------------------------------------++-- | Checks if value is a valid position.+--   A valid position has a format like "double-double"/"latitude-longitude".+isPosition :: Text -> Bool+isPosition pos = isRight . parse position "" $ T.unpack pos++-- | Parse a coordinate.+position :: Parser (Double, Double)+position = do+  lat  <- latitude+  _ <- char '-'+  long <- longitude+  return (lat,long)++-- | Parse a latitude value.+latitude :: Parser Double+latitude = do+  pos <- double+  if pos > -90 && pos < 90+    then return pos+    else fail "latitude out of bounds"++-- | Parse a longitude value.+longitude :: Parser Double+longitude = do+  pos <- double+  if pos > -180 && pos < 180+    then return pos+    else fail "longitude out of bounds"++-- ------------------------------------------------------------+-- normalizer+-- ------------------------------------------------------------++-- | Normalizes valid position+--   A valid position has a format like "double-double"/"latitude-longitude".+normalize :: Text -> Text+normalize pos+  = case parse position "" $ T.unpack pos of+     Right (la,lo) -> T.pack $ intersectPos (format la) (format lo)+     Left _        -> error "normalize positon: invalid position"+  where+  format   :: Double -> String+  format v = dec2bin $ round (v * 10000000)+++-- | Denormalizes internal position into valid position.+--   A valid position has a format like "double-double"/"latitude-longitude".+denormalize :: Text -> Text+denormalize pos+  = T.pack . show' d1 . ('-':) . show' d2 $ ""+  where+  (d1,d2) = ( fromIntegral i1 / 10000000+            , fromIntegral i2 / 10000000+            ) :: (Double,Double)+  (i1,i2) = ( bin2dec odds+            , bin2dec evens+            )++  (odds,evens) = oddsAndEvens sPos++  oddsAndEvens o = case o of+    (x1:x2:xs) -> let (y1,y2) = oddsAndEvens xs in (x1:y1,x2:y2)+    (x1:xs)    -> let (y1,y2) = oddsAndEvens xs in (x1:y1,y2)+    []         -> ([],[])++  sPos = T.unpack pos++  show' = showFFloat (Just 7)++-- ------------------------------------------------------------+-- normalizer helper+-- ------------------------------------------------------------++-- | Decimal representation of a binary encoded string.+--+--   /Note/: The input needs to be valid.+--           @length input >= 2 && all (`elem` "01") input@+bin2dec :: String -> Int+bin2dec (s:i)+  = sign dec+    where+      dec = fst . head . readInt 2 isbc c2b $ i+      sign = if s == '0' then negate else id+bin2dec []+  = error "bin2dec: empty String"++-- | Convert Integer to Binary and normalize result+--   with leading zeros to a length of 32 characters.+--   The first character is the sign: 0 -> negative.+--+--   /Note/: The input needs to be valid.+dec2bin :: Integer -> String+dec2bin i = sign . zeros . bin $ ""+  where+  sign, zeros, bin :: ShowS+  (sign,n) = if i < 0 then (('0':),-i) else (('1':),i)+  bin      = showIntAtBase 2 b2c n+  zeros s  = foldr (\ _ xs -> '0' : xs) s [1..elems]+    where elems = 31 - length s++-- | Merge two lists starting with an element of the first list, then one+--   of the second list and so on.+--   Works like @concat . zipWith (\a b -> a:b:[])@, but pads with zeros.+intersectPos :: String -> String -> String+intersectPos (x:xs) (y:ys) = x   : y   : intersectPos xs ys+intersectPos (x:xs) []     = x   : '0' : intersectPos xs []+intersectPos []     (y:ys) = '0' : y   : intersectPos [] ys+intersectPos _      _      = []++{-+-- ShowS version with accumulator - unnecessary+intersectPos :: String -> String -> ShowS+intersectPos la lo = foldPos' la lo id+    where+    foldPos' (x:xs) (y:ys) a = foldPos' xs ys (\s -> a (x   : y   : s))+    foldPos' (x:xs) []     a = foldPos' xs "" (\s -> a (x   : '0' : s))+    foldPos' []     (y:ys) a = foldPos' "" ys (\s -> a ('0' : y   : s))+    foldPos' []    []      a = a+-}++-- ------------------------------------------------------------+-- Int to binary and vice versa+-- ------------------------------------------------------------++-- | Binary integer to character.+b2c :: Int -> Char+b2c i = case i of+  0 -> '0'+  1 -> '1'+  _ -> error "b2c i with i `notElem` [0,1]"++-- | Character to binary integer.+c2b :: Char -> Int+c2b o = case o of+  '0' -> 0+  '1' -> 1+  _ -> error "c2b c with c `notElem` \"01\""++-- | Is the character a binary number.+isbc :: Char -> Bool+isbc = (`elem` "01")++-- ------------------------------------------------------------+-- parser helper+-- ------------------------------------------------------------++number :: Parser String+number = many1 digit++plus :: Parser String+plus = char '+' *> number++minus :: Parser String+minus = char '-' <:> number++integer :: Parser String+integer = plus <|> minus <|> number++double :: Parser Double+double = fmap rd $ integer <++> decimal+    where rd      = read :: String -> Double+          decimal = option "" $ char '.' <:> number++(<++>) :: Applicative f => f [a] -> f [a] -> f [a]+(<++>) a b = (++) <$> a <*> b++(<:>) :: Applicative f => f a -> f [a] -> f [a]+(<:>) a b = (:) <$> a <*> b++-- ------------------------------------------------------------
+ src/Hunt/Interpreter.hs view
@@ -0,0 +1,820 @@+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE TypeFamilies               #-}++-- ----------------------------------------------------------------------------+{- |+  The interpreter to evaluate 'Command's.+-}+-- ----------------------------------------------------------------------------++module Hunt.Interpreter+  ( -- * Initialization+    initHunt+    -- * Running Commands+  , runCmd+  , execCmd+  , runHunt+    -- * Types+  , Hunt+  , HuntT (..)+  , HuntEnv (..)+  , DefHuntEnv+  )+where++import           Control.Applicative+import           Control.Arrow                 (second)+import           Control.Concurrent.XMVar+import           Control.Monad.Error+import           Control.Monad.Reader++import           Data.Aeson                    (ToJSON (..), object, (.=))+import           Data.Binary                   (Binary, encodeFile)+import qualified Data.ByteString.Lazy          as BL+import           Data.Default+import qualified Data.List                     as L+import qualified Data.Map                      as M+import           Data.Set                      (Set)+import qualified Data.Set                      as S+import           Data.Text                     (Text)+import qualified Data.Text                     as T+import qualified Data.Traversable              as TV++import           Hunt.Common+import           Hunt.Common.ApiDocument       as ApiDoc+import qualified Hunt.Common.DocDesc           as DocDesc+import qualified Hunt.Common.DocIdSet          as DocIdSet+import           Hunt.ContextIndex             (ContextIndex (..), ContextMap)+import qualified Hunt.ContextIndex             as CIx+import           Hunt.DocTable                 (DValue, DocTable)+import qualified Hunt.DocTable                 as DocTable+import           Hunt.DocTable.HashedDocTable+import qualified Hunt.Index                    as Ix+import           Hunt.Index.IndexImpl          (IndexImpl (..), mkIndex)+import           Hunt.Index.Schema.Analyze+import           Hunt.Interpreter.BasicCommand+import           Hunt.Interpreter.Command      (Command)+import           Hunt.Interpreter.Command      hiding (Command (..))+import           Hunt.Query.Intermediate       (ScoredDocs, ScoredWords,+                                                UnScoredDocs, toDocIdSet,+                                                toDocsResult, RankedDoc(..),+                                                toDocumentResultPage,+                                                toWordsResult)+import           Hunt.Query.Language.Grammar+import           Hunt.Query.Processor          (ProcessConfig (..),+                                                initProcessor,+                                                processQueryScoredDocs,+                                                processQueryScoredWords,+                                                processQueryUnScoredDocs)+import           Hunt.Query.Ranking+import           Hunt.Utility                  (showText)+import           Hunt.Utility.Log++import           System.IO.Error               (isAlreadyInUseError,+                                                isDoesNotExistError,+                                                isFullError, isPermissionError,+                                                tryIOError)+import qualified System.Log.Logger             as Log++import           GHC.Stats                     (getGCStats, getGCStatsEnabled)+import           GHC.Stats.Json                ()++{- OLD+import           Data.Function                 (on)+import           Data.List                     (sortBy)+import qualified Hunt.Common.DocIdMap          as DocIdMap+import           Hunt.Common.Document          (DocumentWrapper, setScore, unwrap)+import           Hunt.Utility+import           Hunt.Query.Result             (DocInfo (..), Result (..), WordInfo (..),+                                                WordInfoAndHits (..))+import           Hunt.Query.Processor          (processQuery,+                                                processQueryDocIds)+-- -}+-- ------------------------------------------------------------+--+-- the semantic domains (datatypes for interpretation)+--+-- HuntEnv, Index, ...++-- ------------------------------------------------------------+--+-- the indexer used in the interpreter+-- this should be a generic interpreter in the end+-- but right now its okay to have the indexer+-- replaceable by a type declaration++-- ------------------------------------------------------------+-- Logging++-- TODO: manage exports++-- | Name of the module for logging purposes.+modName :: String+modName = "Hunt.Interpreter"++-- | Log a message at 'DEBUG' priority.+debugM :: MonadIO m => String -> m ()+debugM = liftIO . Log.debugM modName+{-+-- | Log a message at 'WARNING' priority.+warningM :: MonadIO m => String -> m ()+warningM = liftIO . Log.warningM modName+-}+-- | Log a message at 'ERROR' priority.+errorM :: MonadIO m => String -> m ()+errorM = liftIO . Log.errorM modName++{-+-- | Log formated values that get inserted into a context+debugContext :: Context -> Words -> IO ()+debugContext c ws = debugM $ concat ["insert in ", T.unpack c, show . M.toList $ fromMaybe M.empty $ M.lookup c ws]+-- -}++-- ------------------------------------------------------------++-- | The Hunt state and environment.+--   Initialize with default values with 'initHunt'.+data HuntEnv dt = HuntEnv+  { -- | The context index (indexes, document table and schema).+    --   Stored in an 'XMVar' so that read access is always possible.+    huntIndex       :: DocTable dt => XMVar (ContextIndex dt)+    -- | Ranking configuration.+  , huntRankingCfg  :: RankConfig (DValue dt)+    -- | Available context types.+  , huntTypes       :: ContextTypes+    -- | Available normalizers.+  , huntNormalizers :: [CNormalizer]+    -- | Query processor configuration.+  , huntQueryCfg    :: ProcessConfig+  }++-- | Default Hunt environment type.+type DefHuntEnv = HuntEnv (Documents Document)++-- | Initialize the Hunt environment with default values.+initHunt :: DocTable dt => IO (HuntEnv dt)+initHunt = initHuntEnv CIx.empty defaultRankConfig contextTypes normalizers def++-- | Default context types.+contextTypes :: ContextTypes+contextTypes = [ctText, ctInt, ctDate, ctPosition, ctTextSimple, ctPositionRTree]++-- | Default normalizers.+normalizers :: [CNormalizer]+normalizers = [cnUpperCase, cnLowerCase, cnZeroFill]++-- | Initialize the Hunt environment.+initHuntEnv :: DocTable dt+           => ContextIndex dt+           -> RankConfig (DValue dt)+           -> ContextTypes+           -> [CNormalizer]+           -> ProcessConfig+           -> IO (HuntEnv dt)+initHuntEnv ixx rnk opt ns qc = do+  ixref <- newXMVar ixx+  return $ HuntEnv ixref rnk opt ns qc++-- ------------------------------------------------------------+-- Command evaluation monad+-- ------------------------------------------------------------++-- | The Hunt transformer monad. Allows a custom monad to be embedded to combine with other DSLs.++newtype HuntT dt m a+    = HuntT { runHuntT :: ReaderT (HuntEnv dt) (ErrorT CmdError m) a }+      deriving+      (Applicative, Monad, MonadIO, Functor, MonadReader (HuntEnv dt), MonadError CmdError)++instance MonadTrans (HuntT dt) where+  lift = HuntT . lift . lift++-- | The Hunt monad on 'IO'.+type Hunt dt = HuntT dt IO++-- ------------------------------------------------------------++-- | Run the Hunt monad with the supplied environment/state.++runHunt :: DocTable dt => HuntT dt m a -> HuntEnv dt -> m (Either CmdError a)+runHunt env = runErrorT . runReaderT (runHuntT env)++-- | Run the command the supplied environment/state.+runCmd :: (DocTable dt, Binary dt) => HuntEnv dt -> Command -> IO (Either CmdError CmdResult)+runCmd env cmd+  = runErrorT . runReaderT (runHuntT . execCmd $ cmd) $ env++-- | Get the context index.+askIx :: DocTable dt => Hunt dt (ContextIndex dt)+askIx = do+  ref <- asks huntIndex+  liftIO $ readXMVar ref++-- FIXME: io exception-safe?+-- | Modify the context index.+modIx :: DocTable dt+      => (ContextIndex dt -> Hunt dt (ContextIndex dt, a)) -> Hunt dt a+modIx f = do+  ref <- asks huntIndex+  ix <- liftIO $ takeXMVarWrite ref+  (i',a) <- f ix `catchError` putBack ref ix+  liftIO $ putXMVarWrite ref i'+  return a+  where+  putBack ref i e = do+    liftIO $ putXMVarWrite ref i+    throwError e++-- | Modify the context index.+--   Locks the index for reads and writes to prevent excessive memory usage.+--+--   /Note/: This does not fix the memory issues on load entirely because the old index might+--   still be referenced by a concurrent read operation.+modIxLocked :: DocTable dt+            => (ContextIndex dt -> Hunt dt (ContextIndex dt, a)) -> Hunt dt a+modIxLocked f = do+  ref <- asks huntIndex+  ix <- liftIO $ takeXMVarLock ref+  (i',a) <- f ix `catchError` putBack ref ix+  liftIO $ putXMVarLock ref i'+  return a+  where+  putBack ref i e = do+    liftIO $ putXMVarLock ref i+    throwError e++-- | Do something with the context index.+withIx :: DocTable dt => (ContextIndex dt -> Hunt dt a) -> Hunt dt a+withIx f+  = askIx >>= f++-- | Get the type of a context.+askType :: DocTable dt => Text -> Hunt dt ContextType+askType cn = do+  ts <- asks huntTypes+  case L.find (\t -> cn == ctName t) ts of+    Just t -> return t+    _      -> throwResError 410 ("used unavailable context type: " `T.append` cn)++-- | Get the normalizer of a context.+askNormalizer :: DocTable dt => Text -> Hunt dt CNormalizer+askNormalizer cn = do+  ts <- asks huntNormalizers+  case L.find (\t -> cn == cnName t) ts of+    Just t -> return t+    _      -> throwResError 410 ("used unavailable normalizer: " `T.append` cn)++-- | Get the index.+askIndex :: DocTable dt => Text -> Hunt dt IndexImpl+askIndex cn = ctIxImpl <$> askType cn++-- | Throw an error in the Hunt monad.+throwResError :: DocTable dt => Int -> Text -> Hunt dt a+throwResError n msg+    = do errorM $ unwords [show n, T.unpack msg]+         throwError $ ResError n msg++-- ------------------------------------------------------------++-- | Execute the command in the Hunt monad.+execCmd :: (Binary dt, DocTable dt) => Command -> Hunt dt CmdResult+execCmd+  = execBasicCmd . toBasicCommand++-- XXX: kind of obsolete now+-- | Execute the \"low-level\" command in the Hunt monad.++execBasicCmd :: (Binary dt, DocTable dt) => BasicCommand -> Hunt dt CmdResult+execBasicCmd cmd@(InsertList _) = do+  debugM $ "Exec: InsertList [..]"+  execCmd' cmd++execBasicCmd cmd = do+  debugM $ "Exec: " ++ logShow cmd+  execCmd' cmd+++-- | Use 'execBasicCmd'.+--+--   Dispatches basic commands to corresponding functions.++execCmd' :: (Binary dt, DocTable dt) => BasicCommand -> Hunt dt CmdResult+execCmd' (Search q offset mx wg fields)+  = withIx $ execSearch q offset mx wg fields++execCmd' (Completion q mx)+    = withIx $ execCompletion q mx+--  = withIx $ execSearch' (wrapCompletion mx) q++execCmd' (Select q)+  = withIx $ execSelect q++execCmd' (Sequence cs)+  = execSequence cs++execCmd' NOOP+  = return ResOK  -- keep alive test++execCmd' (Status sc)+  = execStatus sc++execCmd' (InsertList docs)+  = modIx $ execInsertList docs++execCmd' (Update doc)+  = modIx $ execUpdate doc++execCmd' (DeleteDocs uris)+  = modIx $ execDeleteDocs uris++execCmd' (DeleteByQuery q)+  = modIx $ execDeleteByQuery q++execCmd' (StoreIx filename)+  = withIx $ execStore filename++execCmd' (LoadIx filename)+  = execLoad filename++execCmd' (InsertContext cx ct)+  = modIx $ execInsertContext cx ct++execCmd' (DeleteContext cx)+  = modIx $ execDeleteContext cx++-- ------------------------------------------------------------++-- | Execute a sequence of commands.+--   The sequence will be aborted if a command fails, but the previous commands will be permanent.++execSequence :: (DocTable dt, Binary dt)=> [BasicCommand] -> Hunt dt CmdResult+execSequence []       = execBasicCmd NOOP+execSequence [c]      = execBasicCmd c+execSequence (c : cs) = execBasicCmd c >> execSequence cs++-- | Insert a context with associated schema.+execInsertContext :: DocTable dt+                  => Context+                  -> ContextSchema+                  -> ContextIndex dt+                  -> Hunt dt (ContextIndex dt, CmdResult)+execInsertContext cx ct ixx+  = do+    -- check if context already exists+    contextExists        <- CIx.hasContextM cx ixx+    unless' (not contextExists)+           409 $ "context already exists: " `T.append` cx++    -- check if type exists in this interpreter instance+    cType                <- askType . ctName . cxType  $ ct+    impl                 <- askIndex . ctName . cxType $ ct+    norms                <- mapM (askNormalizer . cnName) $ cxNormalizer ct++    -- create new index instance and insert it with context+    return $ ( CIx.insertContext cx (newIx impl) (newSchema cType norms) ixx+             , ResOK+             )+  where+  newIx :: IndexImpl -> IndexImpl+  newIx (IndexImpl i) = mkIndex $ Ix.empty `asTypeOf` i+  newSchema cType norms= (ct { cxType = cType, cxNormalizer = norms })++-- | Deletes the context and the schema associated with it.+execDeleteContext :: DocTable dt+                  => Context+                  -> ContextIndex dt+                  -> Hunt dt (ContextIndex dt, CmdResult)+execDeleteContext cx ixx+  = return (CIx.deleteContext cx ixx, ResOK)++-- | Inserts an 'ApiDocument' into the index.+--+-- /Note/: All contexts mentioned in the 'ApiDocument' need to exist.+-- Documents/URIs must not exist.++execInsertList :: DocTable dt+                => [ApiDocument] -> ContextIndex dt -> Hunt dt (ContextIndex dt, CmdResult)+execInsertList docs ixx@(ContextIndex ix _dt)+    = do -- existence check for all referenced contexts in all docs+         checkContextsExistence contexts ixx++         -- check no duplicates in docs+         checkDuplicates duplicates++         -- apidoc should not exist+         mapM_ (flip (checkApiDocExistence False) ixx) docs++         -- all checks done, do the real work+         ixx' <- lift $ CIx.insertList docsAndWords ixx+         return (ixx', ResOK)+    where+      -- compute all contexts in all docs+      contexts+          = M.keys+            . M.unions+            . L.map (M.map (const ()) . adIndex)+            $ docs++      -- convert ApiDocuments to Documents, delete null values,+      -- and break index data into words by applying the scanner+      -- given by the schema spec for the appropriate contexts+      docsAndWords+          = L.map ( (\ (d, _dw, ws) -> (d, ws))+                    . toDocAndWords (CIx.mapToSchema ix)+                    . (\ d -> d {adDescr = DocDesc.deleteNull $ adDescr d})+                  )+            $ docs++      -- compute duplicate URIs by building a frequency table+      -- and looking for entries with counts @> 1@+      duplicates+          = M.keys+            . M.filter (> 1)+            . L.foldl ins M.empty+            . L.map adUri+            $ docs+            where+              ins m k = M.insertWith (+) k (1::Int) m++      -- check and throw error concerning duplicate URIs+      checkDuplicates xs+          = unless' (L.null xs)+              409 $ "duplicate URIs found in document list:" <> showText xs+++-- | Updates an 'ApiDocument'.+--+-- /Note/: All contexts mentioned in the 'ApiDocument' need to exist.+-- Documents/URIs need to exist.++execUpdate :: DocTable dt+           => ApiDocument -> ContextIndex dt -> Hunt dt (ContextIndex dt, CmdResult)++execUpdate doc ixx@(ContextIndex ix dt)+    = do checkContextsExistence contexts ixx+         docIdM <- lift $ DocTable.lookupByURI (uri docs) dt+         case docIdM of+           Just docId+               -> do ixx' <- lift+                             $ CIx.modifyWithDescription (adWght doc) (desc docs) ws docId ixx+                     return (ixx', ResOK)+           Nothing+               -> throwResError 409 $ "document for update not found: " `T.append` uri docs+    where+      contexts+          = M.keys $ adIndex doc+      (docs, _dw, ws)+          = toDocAndWords (CIx.mapToSchema ix) doc+++-- | Test whether the contexts are present and otherwise throw an error.++checkContextsExistence :: DocTable dt+                       => [Context] -> ContextIndex dt -> Hunt dt ()+checkContextsExistence cs ixx+    = do ixxContexts        <- S.fromList <$> CIx.contextsM ixx+         let docContexts     = S.fromList cs+         let invalidContexts = S.difference docContexts ixxContexts+         unless' (S.null invalidContexts)+           409 ( "mentioned context(s) are not present: "+                 <> (showText . S.toList $ invalidContexts)+               )++-- | Test whether the document (URI) already exists+-- (or does not exist depending on the first argument).+--+-- Throws an error if it exists and the first argument is @False@ and vice versa.++checkApiDocExistence :: DocTable dt+                     => Bool -> ApiDocument -> ContextIndex dt -> Hunt dt ()+checkApiDocExistence switch apidoc ixx+    = do let u = adUri apidoc+         mem <- CIx.member u ixx+         unless' (switch == mem)+           409 ( ( if mem+                   then "document already exists: "+                   else "document does not exist: "+                 ) <> u+               )++execSearch :: DocTable dt =>+              Query ->+              Int -> Int ->+              Bool -> Maybe [Text] ->+              ContextIndex dt ->+              Hunt dt CmdResult++execSearch q offset mx wg fields (ContextIndex ix dt)+    = do debugM ("execSearch: " ++ show q)+         cfg    <- asks huntQueryCfg+         scDocs <- liftHunt $+                   runQueryScoredDocsM ix cfg q+         formatPage <$> toDocsResult dt scDocs+    where+      formatPage ds+          = ResSearch $+            LimitedResult+            { lrResult = ds'+            , lrOffset = offset+            , lrMax    = mx+            , lrCount  = length ds+            }+          where+            ds' = map (mkSelect wg fields)+                  . toDocumentResultPage offset mx+                  $ ds++execCompletion :: DocTable dt =>+                  Query ->+                  Int ->+                  ContextIndex dt -> Hunt dt CmdResult+execCompletion q mx (ContextIndex ix _dt)+    = do debugM ("execCompletion: " ++ show q)+         cfg     <- asks huntQueryCfg+         scWords <- liftHunt $+                    runQueryScoredWordsM ix cfg q+         return $ ResSuggestion $ toWordsResult mx scWords+++execSelect :: DocTable dt => Query -> ContextIndex dt -> Hunt dt CmdResult+execSelect q (ContextIndex ix dt)+    = do debugM ("execSelect: " ++ show q)+         res <- liftHunt $ runQueryUnScoredDocsM ix queryConfigDocIds q+         dt' <- DocTable.restrict (toDocIdSet res) dt+         djs <- DocTable.toJSON'DocTable dt'+         return $ ResGeneric djs++-- | Build a selection function for choosing,+-- which parts of a document are contained in the result.+--+-- The 1. param determines, whether the weight of the document is included in the result.+-- The 2. is the list of the description keys, if @Nothing@ is given the complete desc is included.++mkSelect :: Bool -> Maybe [Text] -> (RankedDoc -> RankedDoc)+mkSelect withWeight fields+    = mkSelW withWeight . mkSelF fields+      where+        mkSelW True      = id+        mkSelW False     = RD . second (\d -> d { wght = 1.0 }) . unRD++        mkSelF Nothing   = id+        mkSelF (Just fs) = RD . second (\d -> d {desc = DocDesc.restrict fs (desc d)}) . unRD+++-- | Delete a set of documents.++execDeleteDocs :: DocTable dt => Set URI -> ContextIndex dt -> Hunt dt (ContextIndex dt, CmdResult)+execDeleteDocs d ix+    = do ix' <- lift $ CIx.deleteDocsByURI d ix+         return (ix', ResOK)++-- | Delete all documents matching the query.++execDeleteByQuery :: DocTable dt => Query -> ContextIndex dt -> Hunt dt (ContextIndex dt, CmdResult)+execDeleteByQuery q ixx@(ContextIndex ix _dt)+    = do debugM ("execDeleteByQuery: " ++ show q)+         ds <- toDocIdSet <$>+               (liftHunt $ runQueryUnScoredDocsM ix queryConfigDocIds q)+         if DocIdSet.null ds+           then do debugM "DeleteByQuery: Query result set empty"+                   return (ixx, ResOK)+           else do debugM $ "DeleteByQuery: " ++ show ds+                   ix' <- lift $ CIx.delete ds ixx+                   return (ix', ResOK)++-- ------------------------------------------------------------++-- TODO: catch exceptions:+--       http://hackage.haskell.org/package/base/docs/System-IO.html#v:openFile++-- | Serialize a value to a file.+execStore :: (Binary a, DocTable dt) =>+             FilePath -> a -> Hunt dt CmdResult+execStore filename x = do+  res <- liftIO . tryIOError $ encodeFile filename x+  case res of+      Left  e+          | isAlreadyInUseError e -> throwResError 409 $ "Cannot store index: file is already in use"+          | isPermissionError   e -> throwResError 403 $ "Cannot store index: no access permission to file"+          | isFullError         e -> throwResError 500 $ "Cannot store index: device is full"+          | otherwise             -> throwResError 500 $ showText $ e+      Right _ -> return ResOK++-- TODO: XMVar functions probably not suited for this, locking for load reasonable++-- | Load a context index.+--   The deserialization is more specific because of the existentially typed index.++--   This operation locks the index, otherwise two potentially large indexes could be present at a+--   time. This is still possible if a read operation lasts as long as loading the index.++execLoad :: (Binary dt, DocTable dt) => FilePath -> Hunt dt CmdResult+execLoad filename = do+  ts <- asks huntTypes+  let ix = map ctIxImpl ts+  modIxLocked $ \_ -> do+    ixh@(ContextIndex ixs _) <- decodeFile' ix filename+    ls <- TV.mapM reloadSchema $ CIx.cxMap ixs+    return (ixh{ ciIndex = CIx.mkContextMap ls }, ResOK)+  where+  decodeFile' ts f = do+    res <- liftIO . tryIOError $ CIx.decodeCxIx ts <$> BL.readFile f+    case res of+      Left  e+          | isAlreadyInUseError e -> throwResError 409 $ "Cannot load index: file already in use"+          | isDoesNotExistError e -> throwResError 404 $ "Cannot load index: file does not exist"+          | isPermissionError   e -> throwResError 403 $ "Cannot load index: no access permission to file"+          | otherwise             -> throwResError 500 $ showText e+      Right r -> return r++  reloadSchema (s,ix) = do+    cxt <- askType . ctName . cxType $ s+    ns  <- mapM (askNormalizer . cnName) (cxNormalizer s)+    return $ ( s { cxType       = cxt+                 , cxNormalizer = ns+                 }+             , ix )++-- ------------------------------------------------------------++-- the query interpreters++-- for scored docs (DocIdMap with scores)++runQueryScoredDocsM :: ContextMap+                    -> ProcessConfig+                    -> Query+                    -> IO (Either CmdError ScoredDocs)+runQueryScoredDocsM ix cfg q+    = processQueryScoredDocs st q+      where+        st = initProcessor cfg ix+++-- for unscored docs (DocIdSet), usually called with 'queryConfigDocIds'++runQueryUnScoredDocsM :: ContextMap+                    -> ProcessConfig+                    -> Query+                    -> IO (Either CmdError UnScoredDocs)+runQueryUnScoredDocsM ix cfg q+    = processQueryUnScoredDocs st q+      where+        st = initProcessor cfg ix+++-- for scored docs (DocIdMap with scores++runQueryScoredWordsM :: ContextMap+                     -> ProcessConfig+                     -> Query+                     -> IO (Either CmdError ScoredWords)+runQueryScoredWordsM ix cfg q+    = processQueryScoredWords st q+      where+        st = initProcessor cfg ix+++-- | Query config for \"delete by query\".++queryConfigDocIds :: ProcessConfig+queryConfigDocIds = ProcessConfig def True 0 0++liftHunt :: IO (Either CmdError r) -> Hunt dt r+liftHunt cmd+    = lift cmd >>= either throwError return++-- ------------------------------------------------------------++-- | Get status information about the server\/index, e.g. garbage collection statistics.+execStatus :: DocTable dt => StatusCmd -> Hunt dt CmdResult+execStatus StatusGC+  = do+    statsEnabled <- liftIO getGCStatsEnabled+    if statsEnabled+      then (ResGeneric . toJSON) <$>+           liftIO getGCStats+      else throwResError 501 ("GC stats not enabled. Use `+RTS -T -RTS' to enable them." :: Text)++execStatus StatusDocTable+    = withIx dumpDocTable+      where+        dumpDocTable (ContextIndex _ix dt)+            = ResGeneric <$>+              DocTable.toJSON'DocTable dt++execStatus (StatusContext cx)+    = withIx dumpContext+      where+        dumpContext (ContextIndex ix _dt)+            = (ResGeneric . object . map (uncurry (.=))) <$>+              CIx.lookupAllWithCx cx ix++execStatus (StatusIndex {- context -})+  = withIx _dumpIndex+    where+      -- context = "type"+      _dumpIndex (ContextIndex _ix _dt)+          = throwResError 501 $ "status of Index not yet implemented"++-- ------------------------------------------------------------++-- | Throw an error unless the first argument is @True@, and otherwise do nothing.+unless' :: DocTable dt+       => Bool -> Int -> Text -> Hunt dt ()+unless' b code text = unless b $ throwResError code text++-- ------------------------------------------------------------++{- OLD+askDocTable :: DocTable dt => Hunt dt dt+askDocTable = askIx >>= return . ciDocs++-- | Get the context weightings.+askContextsWeights :: DocTable dt => Hunt dt ContextWeights -- (M.Map Context Weight)+askContextsWeights+  = withIx (\(ContextIndex _ _ schema) -> return $ M.map cxWeight schema)+-- -}+++{- OLD+-- | Run a query.+runQueryM       :: DocTable dt+                => ContextMap Occurrences+                -> Schema+                -> ProcessConfig+                -> dt+                -> Query+                -> IO (Either CmdError (Result (DValue dt)))+runQueryM ix s cfg dt q = processQuery st dt q+  where+  st = initProcessor cfg ix s++runQueryDocIdsM :: ContextMap Occurrences+                -> Schema+                -> Query+                -> IO (Either CmdError DocIdSet)+runQueryDocIdsM ix s q+    = processQueryDocIds st q+      where+        st = initProcessor queryConfigDocIds ix s+-- -}+-- ------------------------------------------------------------++{- old stuff, but still used in completions++-- | Search the index.+--   Requires a result transformation function, e.g. 'wrapSearch' or 'wrapCompletion'.+execSearch' :: (DocTable dt, e ~ DValue dt)+            => (Result e -> CmdResult)+            -> Query+            -> ContextIndex dt+            -> Hunt dt CmdResult+execSearch' f q (ContextIndex ix dt s)+  = do+    cfg <- asks huntQueryCfg+    r   <- lift $ runQueryM ix s cfg dt q+    rc  <- asks huntRankingCfg+    cw  <- askContextsWeights+    case r of+      Left  err -> throwError err+      Right res -> do -- debugM ("doc  ranking: " ++ show (docHits  res))+                      -- debugM ("word ranking: " ++ show (wordHits res))+                      res' <- rank rc dt cw $ res+                      -- debugM ("doc  result : " ++ show (docHits  res'))+                      -- debugM ("word result : " ++ show (wordHits res'))+                      return (f res')++-- FIXME: signature to result+-- | Wrap the query result for search.+wrapSearch :: (DocumentWrapper e) => (Document -> Document) -> Int -> Int -> Result e -> CmdResult+wrapSearch select offset mx+  = ResSearch+    . mkLimitedResult offset mx+--    . map fst -- remove score from result+    . map (uncurry (flip setScore))+    . map (first select)+    . sortBy (descending `on` snd) -- sort by score+    . map (\(_did, (di, _dch)) -> (unwrap . document $ di, docScore di))+    . DocIdMap.toList+    . docHits++-- | Wrap the query result for auto-completion.+wrapCompletion :: Int -> Result e -> CmdResult+wrapCompletion mx+  = ResCompletion+    . take mx+    . map (\(word,_score,terms') -> (word, terms')) -- remove score from result+    . sortBy (descending `on` (\(_,score',_) -> score')) -- sort by score+    . map (\(c, (WIH wi _wch)) -> (c, wordScore wi, terms wi))+    . M.toList+    . wordHits++-- -}++-- ------------------------------------------------------------
+ src/Hunt/Interpreter/BasicCommand.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE OverloadedStrings #-}++-- ----------------------------------------------------------------------------+{- |+  Basic \"low-level\" commands that are directly interpreted.++  "Hunt.Interpreter.Command" defines the \"high-level\" commands accepted by the (JSON) API.+-}+-- ----------------------------------------------------------------------------++module Hunt.Interpreter.BasicCommand+  ( BasicCommand (..)+  , StatusCmd (..)+  )+where++import           Control.Applicative+import           Control.Monad               (mzero)++import           Data.Aeson+import qualified Data.Aeson                  as JS (Value (..))+import           Data.Set                    (Set)+import           Data.Text                   (Text)++import           Hunt.Common.ApiDocument+import           Hunt.Common.BasicTypes+import           Hunt.Index.Schema+import           Hunt.Query.Language.Grammar (Query (..))++import           Hunt.Utility.Log++-- ------------------------------------------------------------++-- | The \"low-level\" commands that are actually interpreted.+data BasicCommand+  -- | Search query with pagination.+  = Search        { icQuery    :: Query+                  , icOffsetSR :: Int+                  , icMaxSR    :: Int+                  , icWeight   :: Bool+                  , icFields   :: Maybe [Text]+                  }++  -- | Auto-completion query with a limit.+  | Completion    { icPrefixCR :: Query+                  , icMaxCR    :: Int+                  }++  -- | Raw query without any ranking, scoring and ordering+  | Select        { icQuery :: Query }++  -- | Insert documents.+  | InsertList    { icDocs :: [ApiDocument] }++  -- | Update the document description.+  | Update        { icDoc :: ApiDocument }++  -- | Delete documents by 'URI'.+  | DeleteDocs   { icUris :: Set URI }++  -- | Delete all documents of the query result.+  | DeleteByQuery { icQueryD :: Query }++  -- | Insert a context and the associated schema.+  | InsertContext { icICon   :: Context+                  , icSchema :: ContextSchema+                  }+  -- | Delete a context.+  | DeleteContext { icDCon :: Context }++  -- | Deserialize the index.+  | LoadIx        { icPath :: FilePath }+  -- | Serialize the index.+  | StoreIx       { icPath :: FilePath }++  -- | Query general information about the server/index.+  | Status        { icStatus :: StatusCmd }++  -- | Sequence commands.+  | Sequence      { icCmdSeq :: [BasicCommand] }+  -- | No operation. Can be used in control flow and as an alive test.+  | NOOP+  deriving (Show)++-- | Available status commands.+data StatusCmd+  = StatusGC              -- ^ Garbage collection statistics.+  | StatusDocTable        -- ^ Document table JSON dump.+  | StatusIndex           -- ^ Index JSON dump.+  | StatusContext Context -- ^ Index context dump+    deriving (Show)++-- ------------------------------------------------------------+-- XXX: maybe duplicate StatusCmd to keep this module clean++instance ToJSON StatusCmd where+  toJSON StatusGC          = JS.String "gc"+  toJSON StatusDocTable    = JS.String "doctable"+  toJSON StatusIndex       = JS.String "index"+  toJSON (StatusContext c) = object ["context" .= c] -- JS.String $ "context/" `T.append` c++instance FromJSON StatusCmd where+  parseJSON (Object o)             = StatusContext <$> o .: "context"+  parseJSON (JS.String "gc"      ) = return StatusGC+  parseJSON (JS.String "doctable") = return StatusDocTable+  parseJSON (JS.String "index"   ) = return StatusIndex+  parseJSON _                      = mzero++-- ------------------------------------------------------------++instance LogShow BasicCommand where+  logShow (InsertList docs) = "InsertList " ++ show (map adUri docs)+  logShow (Update doc) = "Update {icDoc = " ++ logShow doc ++ "\", ..}"+  logShow (Sequence _) = "Sequence"+  logShow o = show o++-- ------------------------------------------------------------
+ src/Hunt/Interpreter/Command.hs view
@@ -0,0 +1,321 @@+{-# LANGUAGE OverloadedStrings #-}++-- ----------------------------------------------------------------------------+{- |+  \"High-level\" commands that are accepted by the (JSON) API.++  These commands are translated with 'toBasicCommand' to 'BasicCommand's which can be interpreted.+-}+-- ----------------------------------------------------------------------------++module Hunt.Interpreter.Command+  ( Command (..)+  , StatusCmd (..)+  , CmdResult (..)+  , CmdError (..)+  , CmdRes (..)+  , toBasicCommand+  )+where++import           Control.Applicative+import           Control.Monad                 (mzero)+import           Control.Monad.Error           (Error (..))+import           Control.DeepSeq++import           Data.Aeson+import           Data.List+import qualified Data.Set                      as S+import           Data.Text                     (Text)+import qualified Data.Text                     as T++import           Hunt.Common.ApiDocument+import           Hunt.Common.BasicTypes+import           Hunt.Index.Schema+import           Hunt.Query.Language.Grammar   (Query (..))+import           Hunt.Query.Intermediate       (RankedDoc)++import           Hunt.Interpreter.BasicCommand (BasicCommand, StatusCmd (..))+import qualified Hunt.Interpreter.BasicCommand as Cmd++import           Hunt.Utility.Log++-- ------------------------------------------------------------++-- | The \"high-level\" commands accepted by the 'Interpreter' \/ JSON API.+--   These are translated to 'BasicCommand's.++data Command+  -- | Search query with pagination.+  = Search        { icQuery    :: Query+                  , icOffsetSR :: Int+                  , icMaxSR    :: Int+                  , icWeight   :: Bool+                  , icFields   :: Maybe [Text]+                  }+  -- | Auto-completion query with a limit.+  | Completion    { icPrefixCR :: Query+                  , icMaxCR    :: Int+                  }+  -- | Raw query without any ranking, scoring and ordering+  | Select        { icQuery :: Query }++  -- | Insert a document.+  | Insert        { icDoc :: ApiDocument }++  -- | Update a documents' description.+  | Update        { icDoc :: ApiDocument }++  -- | Delete a documents by 'URI'.+  | Delete        { icUri :: URI }++  -- | Delete all documents of the query result.+  | DeleteByQuery { icQueryD :: Query }++  -- | Insert a context and the associated schema.+  | InsertContext { icIContext :: Context+                  , icSchema   :: ContextSchema+                  }+  -- | Delete a context.+  | DeleteContext { icDContext :: Context }++  -- | Deserialize the index.+  | LoadIx        { icPath :: FilePath }++  -- | Serialize the index.+  | StoreIx       { icPath :: FilePath }++  -- | Query general information about the server/index.+  | Status        { icStatus :: StatusCmd }++  -- | Sequence commands.+  | Sequence      { icCmdSeq :: [Command] }++  -- | No operation. Can be used in control flow and as an alive test.+  | NOOP+  deriving (Show)++-- ------------------------------------------------------------++-- | The result of an interpreted command.++data CmdResult+  -- | The command was processed successfully.+  = ResOK++  -- | The search results.+  | ResSearch       { crRes :: LimitedResult RankedDoc }++  -- | The auto-completion results.+  | ResCompletion   { crWords :: [(Text, [Text])] }++  -- | The simplified completion result++  | ResSuggestion   { crSugg :: [(Text, Score)] }++  -- | A generic JSON result.+  | ResGeneric      { crGen :: Value }+  deriving (Show, Eq)++instance NFData CmdResult where+  rnf (ResSearch r)     = r `seq` ()+  rnf (ResCompletion c) = c `seq` ()+  rnf (ResSuggestion s) = s `seq` ()+  rnf _                 = ()++-- | An error during processing of the command.+--   This includes a error code and a message.++data CmdError+  = ResError+    { ceCode :: Int  -- ^ Error code.+    , ceMsg  :: Text -- ^ Message describing the error.+    } deriving (Show)++instance NFData CmdError where+  rnf (ResError i t) = t `seq` i `seq` ()++-- ------------------------------------------------------------++-- | auxiliary type for parsing JSON CmdResult's of various kinds+--+-- usefull in hunt applications, not used within the hunt server++newtype CmdRes a = CmdRes { unCmdRes :: a }+    deriving (Show)++instance (FromJSON a) => FromJSON (CmdRes a) where+    parseJSON (Object o) = do+      c <- o .: "code"+      case (c :: Int) of+        0 -> CmdRes <$> o .: "msg"+        _ -> mzero+    parseJSON _ = mzero++-- ------------------------------------------------------------++instance LogShow Command where+  logShow (Insert doc) = "Insert {icDoc = " ++ logShow doc ++ "\", ..}"+  logShow (Update doc) = "Update {icDoc = " ++ logShow doc ++ "\", ..}"+  logShow (Sequence _) = "Sequence"+  logShow o = show o++-- ------------------------------------------------------------+-- JSON instances+-- ------------------------------------------------------------++instance ToJSON Command where+  toJSON o = case o of+    Search q ofs mx wght sel+                      -> object . cmd "search"         $+                         [ "query"  .= q+                         , "offset" .= ofs              -- the start of the result list+                         , "max"    .= mx               -- max length of result list+                         ]+                         +++                         ( if wght                      -- doc weight included in result (yes/no)+                           then [ "weight" .= wght ]+                           else []+                         )+                         ++                             -- descr fields included in result+                         maybe [] (\ fs -> [ "fields" .= fs ]) sel++    Completion s mx   -> object . cmd "completion"     $ [ "text"     .= s, "max" .= mx ]+    Select q          -> object . cmd "select"         $ [ "query"    .= q ]+    Insert d          -> object . cmd "insert"         $ [ "document" .= d ]+    Update d          -> object . cmd "update"         $ [ "document" .= d ]+    Delete u          -> object . cmd "delete"         $ [ "uri"      .= u ]+    DeleteByQuery q   -> object . cmd "delete-by-query"$ [ "query"    .= q ]+    InsertContext c s -> object . cmd "insert-context" $ [ "context"  .= c, "schema" .= s ]+    DeleteContext c   -> object . cmd "delete-context" $ [ "context"  .= c ]+    LoadIx  f         -> object . cmd "load"           $ [ "path"     .= f ]+    StoreIx f         -> object . cmd "store"          $ [ "path"     .= f ]+    Status  sc        -> object . cmd "status"         $ [ "status"   .= sc ]+    NOOP              -> object . cmd "noop"           $ []+    Sequence cs       -> toJSON cs+    where+    cmd c = (:) ("cmd" .= (c :: Text))++instance FromJSON Command where+  parseJSON (Object o) = do+    c <- o .: "cmd"+    case (c :: Text) of+      "search"         -> Search        <$> o .:  "query"+                                        <*> o .:? "offset" .!= 0+                                        <*> o .:? "max"    .!= (-1)+                                        <*> o .:? "weight" .!= False+                                        <*> o .:? "fields"++      "completion"     -> Completion    <$> o .: "text"+                                        <*> o .: "max"++      "select"         -> Select        <$> o .: "query"+      "insert"         -> Insert        <$> o .: "document"+      "update"         -> Update        <$> o .: "document"+      "delete"         -> Delete        <$> o .: "uri"+      "delete-by-query"-> DeleteByQuery <$> o .: "query"++      "insert-context" -> InsertContext <$> o .: "context"+                                        <*> o .: "schema"++      "delete-context" -> DeleteContext <$> o .: "context"+      "load"           -> LoadIx        <$> o .: "path"+      "store"          -> StoreIx       <$> o .: "path"+      "noop"           -> return NOOP+      "status"         -> Status        <$> o .: "status"+      _                -> mzero++  parseJSON v          =  Sequence      <$> parseJSON v++instance ToJSON CmdResult where+  toJSON o = case o of+    ResOK           -> object . code 0 $ []+    ResSearch r     -> object . code 0 $ [ "res" .= r ]+    ResCompletion w -> object . code 0 $ [ "res" .= w ]+    ResSuggestion r -> object . code 0 $ [ "res" .= r ]+    ResGeneric v    -> object . code 0 $ [ "res" .= v ]+    where+    code i = (:) ("code" .= (i :: Int))++instance Error CmdError where+  strMsg s = ResError 500 . T.pack $ "internal server error: " ++ s++instance ToJSON CmdError where+  toJSON (ResError c m) = object+    [ "code" .= c+    , "msg"  .= m+    ]++instance FromJSON CmdError where+  parseJSON (Object o) = ResError <$> o .: "code"+                                  <*> o .: "msg"+  parseJSON _ = mzero++-- ------------------------------------------------------------++-- TODO: - flattening of 'Sequence's?++-- | Transform the supported input command into lower level commands which are actually interpreted.+--+--   Transformations:+--+--     - Multiple 'Cmd.Delete's into a single 'DeleteDocs'.+--+--     - Multiple 'Cmd.Insert's into a single or multiple 'InsertList's.+toBasicCommand :: Command -> BasicCommand+toBasicCommand (Sequence cs) = Cmd.Sequence $ opt cs+  where+  opt :: [Command] -> [BasicCommand]+  opt cs' = concatMap optGroup $ groupBy equalHeads cs'+  -- requires the commands to be grouped by constructor+  optGroup :: [Command] -> [BasicCommand]+  -- groups of delete to DeleteDocs+  optGroup cs'@(Delete{}:_)+    = [foldl (\(Cmd.DeleteDocs us) (Delete u)+                -> Cmd.DeleteDocs (S.insert u us)) (Cmd.DeleteDocs S.empty) cs']+  -- groups of Insert to InsertList+  -- TODO: remove constant+  optGroup cs'@(Insert{}:_)+    = [splitBatch maxBound $ foldl (\(Cmd.InsertList us) (Insert u)+                -> Cmd.InsertList (u:us)) (Cmd.InsertList []) cs']+  optGroup cs'@(Sequence{}:_)+    = map toBasicCommand cs'+  optGroup cs'+    = map toBasicCommand cs'+  -- group by constructor+  -- NOTE: add constructors to use in optGroup+  equalHeads :: Command -> Command -> Bool+  equalHeads Delete{}   Delete{}   = True+  equalHeads Insert{}   Insert{}   = True+  equalHeads Sequence{} Sequence{} = True+  equalHeads _ _                   = False++toBasicCommand (Delete u)          = Cmd.DeleteDocs $ S.singleton u+toBasicCommand (DeleteByQuery q)   = Cmd.DeleteByQuery q+toBasicCommand (Search a b c d e)  = Cmd.Search a b c d e+toBasicCommand (Completion a b)    = Cmd.Completion a b+toBasicCommand (Select a)          = Cmd.Select a+toBasicCommand (Insert a)          = Cmd.InsertList [a]+toBasicCommand (Update a)          = Cmd.Update a+toBasicCommand (InsertContext a b) = Cmd.InsertContext a b+toBasicCommand (DeleteContext a)   = Cmd.DeleteContext a+toBasicCommand (LoadIx a)          = Cmd.LoadIx a+toBasicCommand (StoreIx a)         = Cmd.StoreIx a+toBasicCommand (Status a)          = Cmd.Status a+toBasicCommand (NOOP)              = Cmd.NOOP++-- | Splits big batch inserts to smaller ones with at most @n@ elements.+--   This can avoid running out of memory for large 'InsertList's.+splitBatch :: Int -> BasicCommand -> BasicCommand+splitBatch n (Cmd.InsertList xs)+    = Cmd.Sequence $ map Cmd.InsertList $ splitEvery n xs+splitBatch _ cmd+    = cmd++splitEvery :: Int -> [a] -> [[a]]+splitEvery _ [] = []+splitEvery n list = first : splitEvery n rest+  where+  (first,rest) = splitAt n list++-- ------------------------------------------------------------
+ src/Hunt/Query/Fuzzy.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE OverloadedStrings #-}++-- ----------------------------------------------------------------------------++{- |+  Module     : Hunt.Query.Fuzzy+  Copyright  : Copyright (C) 2007, 2008 Timo B. Huebel+  License    : MIT++  Maintainer : Timo B. Huebel (tbh@holumbus.org)+  Stability  : experimental+  Portability: portable+  Version    : 0.2++  The unique Holumbus mechanism for generating fuzzy sets.+-}++-- ----------------------------------------------------------------------------++module Hunt.Query.Fuzzy+  (+  -- * Fuzzy types+  FuzzySet+  , Replacements+  , Replacement+  , FuzzyScore+  , FuzzyConfig (..)++  -- * Predefined replacements+  , englishReplacements+  , germanReplacements++  -- * Generation+  , fuzz++  -- * Conversion+  , toList+  )+where++import           Data.Binary+import           Data.Default+import           Data.Function+import           Data.List+import           Data.Maybe       (fromMaybe)++import           Control.Applicative++import           Data.Map         (Map)+import qualified Data.Map         as M++import           Data.Text        (Text)+import qualified Data.Text        as T+import           Data.Text.Binary ()++-- ------------------------------------------------------------++-- | A set of string which have been "fuzzed" with an associated score.+type FuzzySet = Map Text FuzzyScore++-- | Some replacements which can be applied to a string to generate a 'FuzzySet'. The scores of+-- the replacements will be normalized to a maximum of 1.0.+type Replacements = [Replacement]++-- | A single replacements, where the first will be replaced by the second and vice versa in+-- the target string. The score indicates the amount of fuzzines that one single application+-- of this replacement in just one direction will cause on the target string.+type Replacement = ((Text,Text), FuzzyScore)++-- | The score indicating an amount of fuzziness.+type FuzzyScore = Float++-- | The configuration of a fuzzy query.+data FuzzyConfig+  = FuzzyConfig+    { applyReplacements  :: Bool         -- ^ Indicates whether the replacements should be applied.+    , applySwappings     :: Bool         -- ^ Indicates whether the swapping of adjacent characters should be applied.+    , maxFuzziness       :: FuzzyScore   -- ^ The maximum allowed fuzziness.+    , customReplacements :: Replacements -- ^ The replacements that should be applied.+    }+  deriving (Show)++-- ------------------------------------------------------------++instance Default FuzzyConfig where+  def = FuzzyConfig True True 1.0 englishReplacements++instance Binary FuzzyConfig where+  put (FuzzyConfig r s m f) = put r >> put s >> put m >> put f+  get = FuzzyConfig <$> get <*> get <*> get <*> get++-- ------------------------------------------------------------++-- | Some default replacements for the english language.+englishReplacements :: Replacements+englishReplacements =+  [ (("l", "ll"), 0.2)+  , (("t", "tt"), 0.2)+  , (("r", "rr"), 0.2)+  , (("e", "ee"), 0.2)+  , (("o", "oo"), 0.2)+  , (("s", "ss"), 0.2)++  , (("g", "ck"), 0.4)+  , (("k", "ck"), 0.4)+  , (("ea", "ee"), 0.4)+  , (("ou", "oo"), 0.4)+  , (("ou", "au"), 0.4)+  , (("ou", "ow"), 0.4)++  , (("s", "c"), 0.6)+  , (("uy", "ye"), 0.6)+  , (("y", "ey"), 0.6)+  , (("kn", "n"), 0.6)+  ]++-- | Some default replacements for the german language.+germanReplacements :: Replacements+germanReplacements =+  [ (("l", "ll"), 0.2)+  , (("t", "tt"), 0.2)+  , (("n", "nn"), 0.2)+  , (("r", "rr"), 0.2)+  , (("i", "ie"), 0.2)+  , (("ei", "ie"), 0.2)+  , (("k", "ck"), 0.2)++  , (("d", "t"), 0.4)+  , (("b", "p"), 0.4)+  , (("g", "k"), 0.4)+  , (("g", "ch"), 0.4)+  , (("c", "k"), 0.4)+  , (("s", "z"), 0.4)+  , (("u", "ou"), 0.4)++  , (("ü", "ue"), 0.1)+  , (("ä", "ae"), 0.1)+  , (("ö", "oe"), 0.1)+  , (("ß", "ss"), 0.1)+  ]++-- | Continue fuzzing a string with the an explicitly specified list of replacements until+-- a given score threshold is reached.+fuzz :: FuzzyConfig -> Text -> FuzzySet+fuzz cfg s = M.delete s (fuzz' (fuzzLimit cfg 0.0 s))+  where+  fuzz' :: FuzzySet -> FuzzySet+  fuzz' fs = if M.null more then fs else M.unionWith min fs (fuzz' more)+    where+    -- The current score is doubled on every recursive call, because fuzziness increases exponentially.+    more = M.foldrWithKey (\sm sc res -> M.unionWith min res (fuzzLimit cfg (sc + sc) sm)) M.empty fs++-- | Fuzz a string and limit the allowed score to a given threshold.+fuzzLimit :: FuzzyConfig -> FuzzyScore -> Text -> FuzzySet+fuzzLimit cfg sc s = if sc <= th then M.filter (<= th) (fuzzInternal cfg sc s) else M.empty+  where+  th = maxFuzziness cfg++-- | Fuzz a string with an list of explicitly specified replacements and combine the scores+-- with an initial score.+fuzzInternal :: FuzzyConfig -> FuzzyScore -> Text -> FuzzySet+fuzzInternal cfg sc s = M.unionWith min replaced swapped+  where+  replaced = let rs = customReplacements cfg in if applyReplacements cfg+             then foldr (\r res -> M.unionWith min res (applyFuzz (replace rs r) sc s)) M.empty rs+             else M.empty+  swapped = if applySwappings cfg+            then applyFuzz swap sc s+            else M.empty++-- | Applies a fuzzy function to a string. An initial score is combined with the new score+-- for the replacement.+applyFuzz :: (Text -> Text -> [(Text, FuzzyScore)]) -> FuzzyScore -> Text -> FuzzySet+applyFuzz f sc s = apply (init $ T.inits s) (init $ T.tails s)+  where+  apply :: [Text] -> [Text] -> FuzzySet+  apply [] _ = M.empty+  apply _ [] = M.empty+  apply (pr:prs) (su:sus) = M.unionsWith min $ apply prs sus:map create (f pr su)+    where+    create (fuzzed, score) = M.singleton fuzzed (sc + score * calcWeight (T.length pr) (T.length s))++-- | Apply a replacement in both directions to the suffix of a string and return the complete+-- string with a score, calculated from the replacement itself and the list of replacements.+replace :: Replacements -> Replacement -> Text -> Text -> [(Text, FuzzyScore)]+replace rs ((r1, r2), s) prefix suffix = replace' r1 r2 ++ replace' r2 r1+  where+  replace' tok sub = if replaced == suffix then [] else [(prefix `T.append` replaced, score)]+    where+    replaced = replaceFirst tok sub suffix+    score = s / (snd $ maximumBy (compare `on` snd) rs)++-- | Swap the first two characters of the suffix and return the complete string with a score or+-- Nothing if there are not enough characters to swap.+swap :: Text -> Text -> [(Text, FuzzyScore)]+swap prefix str = fromMaybe [] $ do+  (s1, suffix0) <- T.uncons str+  (s2, suffix)  <- T.uncons suffix0+  return [(prefix `T.append` (s2 `T.cons` s1 `T.cons` suffix), 1.0)]++-- | Calculate the weighting factor depending on the position in the string and it's total length.+calcWeight :: Int -> Int -> FuzzyScore+calcWeight pos len = (l - p) / l+  where+  p = fromIntegral pos+  l = fromIntegral len++-- | Searches a prefix and replaces it with a substitute in a list.+replaceFirst :: Text -> Text -> Text -> Text+replaceFirst xs' ys' zs'+    = case () of+      _ | T.null xs' -> ys' `T.append` zs'+        | T.null zs' -> T.empty+        | otherwise -> let (x, xs) = (T.head xs', T.tail xs')+                           (y, ys) = (T.head ys', T.tail ys')+                           (z, zs) = (T.head zs', T.tail zs')+                       in if x == z && xs' `T.isPrefixOf` zs' then+                            if T.null ys' then replaceFirst xs T.empty zs+                            else y `T.cons` replaceFirst xs ys zs+                          else zs'++-- | Transform a fuzzy set into a list (ordered by score).+toList :: FuzzySet -> [ (Text, FuzzyScore) ]+toList = sortBy (compare `on` snd) . M.toList++-- ------------------------------------------------------------
+ src/Hunt/Query/Intermediate.hs view
@@ -0,0 +1,657 @@+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE TypeFamilies               #-}++-- ----------------------------------------------------------------------------+{- |+  The intermediate query results which have to be merged for the various combinatorial operations.++  'toResult' creates the final result which includes the document (and word) hits.+-}+-- ----------------------------------------------------------------------------++module Hunt.Query.Intermediate+    ( ScoredResult(..)+    , Aggregate(..)++    , ScoredDocs+    , ScoredWords+    , ScoredContexts+    , ScoredOccs+    , ScoredRawDocs+    , ScoredCx+    , UnScoredDocs+    , RankedDoc (..)++    , toScoredDocs+    , boostAndAggregateCx+    , fromCxRawResults+    , fromRawResult+    , limitRawResult+    , limitCxRawResults+    , contextWeights+    , filterByDocSet+    , toDocIdSet+    , toDocsResult+    , toDocumentResultPage+    , toWordsResult++    , evalSequence+    , evalFollow+    , evalNear+    , evalOr+    , evalAnd+    , evalAndNot+    , evalBoost+    , evalPrim+    )+where++import           Prelude                   hiding (null)++import           Control.Applicative       hiding (empty)+import           Control.Arrow             (second, (***))++import qualified Data.LimitedPriorityQueue as Q+import qualified Data.List                 as L+import           Data.Map                  (Map)+import qualified Data.Map                  as M+import           Data.Maybe+import           Data.Aeson+import qualified Data.HashMap.Strict       as HM+import           Hunt.Query.Result         hiding (null)++import           Hunt.Common+import qualified Hunt.Common.DocIdMap      as DM+import qualified Hunt.Common.DocIdSet      as DS+import           Hunt.Common.Document      (DocumentWrapper (..))+import qualified Hunt.Common.Occurrences   as Occ+import qualified Hunt.Common.Positions     as Pos+import           Hunt.DocTable             (DocTable)+import qualified Hunt.DocTable             as Dt++-- import           Debug.Trace++-- ------------------------------------------------------------+--+-- The Monoid @mempty@ acts as empty result,+-- (<>) is the union of scored results++class Monoid a => ScoredResult a where+    boost            :: Score -> a -> a+    nullSC           :: a -> Bool+    differenceSC     :: a -> a -> a+    intersectSC      :: a -> a -> a+    intersectDisplSC :: Int -> a -> a -> a+    intersectFuzzySC :: Int -> Int -> a -> a -> a++-- ------------------------------------------------------------++-- The result type for document search, every doc is associated with a score++newtype ScoredDocs+    = SDS (DocIdMap Score)+      deriving (Show)++instance Monoid ScoredDocs where+    mempty+        = SDS DM.empty+    mappend (SDS m1) (SDS m2)+        = SDS $ DM.unionWith (<>) m1 m2++instance ScoredResult ScoredDocs where+    boost b (SDS m1)+        = SDS $ DM.map (b *) m1++    nullSC (SDS m1)+        = DM.null m1++    differenceSC (SDS m1) (SDS m2)+        = SDS $ DM.difference m1 m2++    intersectSC (SDS m1) (SDS m2)+        = SDS $ DM.intersectionWith (+) m1 m2++    intersectDisplSC _disp+        = intersectSC++    intersectFuzzySC _lb _ub+        = intersectSC++toScoredDocs :: Occurrences -> ScoredDocs+toScoredDocs os+    = SDS $ DM.map toScore os+      where+        toScore = mkScore . fromIntegral . Pos.size++-- ------------------------------------------------------------++-- | The result type for unscored search of documents+--+-- used when all matching docs must be processed,+-- e.g. in DeleteByQuery commands++newtype UnScoredDocs+    = UDS DS.DocIdSet+      deriving (Show, Monoid)++instance ScoredResult UnScoredDocs where+    boost _b uds+        = uds++    nullSC (UDS s)+        = DS.null s++    differenceSC (UDS s1) (UDS s2)+        = UDS $ DS.difference s1 s2++    intersectSC (UDS s1) (UDS s2)+        = UDS $ DS.intersection s1 s2++    intersectDisplSC _disp+        = intersectSC++    intersectFuzzySC _lb _ub+        = intersectSC++toUnScoredDocs :: Occurrences -> UnScoredDocs+toUnScoredDocs os+    = UDS . DS.fromList . DM.keys $ os++toDocIdSet :: UnScoredDocs -> DS.DocIdSet+toDocIdSet (UDS ds) = ds++-- ------------------------------------------------------------++-- The result type for word search,+-- this is the required result type for completions search++newtype ScoredWords+    = SWS (Map Word Score)+      deriving (Show)++type ScoredContexts = ScoredWords++instance Monoid ScoredWords where+    mempty+        = SWS M.empty++    mappend (SWS m1) (SWS m2)+        = SWS $ M.unionWith (<>) m1 m2++instance ScoredResult ScoredWords where+    boost b (SWS m1)+        = SWS $ M.map (b *) m1++    nullSC (SWS m1)+        = M.null m1++    differenceSC (SWS m1) (SWS m2)+        = SWS $ M.difference m1 m2++    intersectSC (SWS m1) (SWS m2)+        = SWS $ M.intersectionWith (+) m1 m2++    intersectDisplSC _disp+        = intersectSC++    intersectFuzzySC _lb _ub+        = intersectSC++-- ------------------------------------------------------------++data ScoredOccs+    = SCO Score Occurrences+      deriving (Show)++instance Monoid ScoredOccs where+    mempty+        = SCO defScore DM.empty+    mappend (SCO s1 d1) (SCO s2 d2)+        = SCO ((s1 + s2) / 2.0) (DM.unionWith Pos.union d1 d2)++instance ScoredResult ScoredOccs where+    boost b (SCO s d)+        = SCO (b * s) d++    nullSC (SCO _s d)+        = DM.null d++    differenceSC (SCO s1 d1) (SCO _s2 d2)+        = SCO s1 (DM.difference d1 d2)++    intersectSC (SCO s1 d1) (SCO s2 d2)+        = SCO (s1 + s2) (Occ.intersectOccurrences Pos.union d1 d2)++    intersectDisplSC disp (SCO s1 d1) (SCO s2 d2)+        = SCO (s1 + s2) (Occ.intersectOccurrences (Pos.intersectionWithDispl disp) d1 d2)++    intersectFuzzySC lb ub (SCO s1 d1) (SCO s2 d2)+        = SCO (s1 + s2) (Occ.intersectOccurrences (Pos.intersectionWithIntervall lb ub) d1 d2)++-- ------------------------------------------------------------++-- A result type for searching phrases and context search,+-- every word hit or word sequence hit is+-- associated with a score and a DocIdMap containing+-- the docs and position.+--+-- The positions are neccessary in phrase and context search,+-- afterwards the positions can be accumulated into a score,+-- e.g. by counting the occurences+--+-- A RawResult can easily be converted into this type++newtype ScoredRawDocs+    = SRD [([Word], ScoredOccs)]+      deriving (Show)++instance Monoid ScoredRawDocs where+    mempty+        = SRD []+    mappend (SRD xs1) (SRD xs2)+        = SRD $ xs1 ++ xs2++instance ScoredResult ScoredRawDocs where+    boost b (SRD xs)+        = SRD $ L.map (second (boost b)) xs++    nullSC (SRD xs)+        = L.null xs++    differenceSC (SRD xs1) (SRD xs2)+        = srd $ [(ws1, SCO sc1 (diff occ1 xs2)) | (ws1, SCO sc1 occ1) <- xs1]+          where+            diff occ xs+                = L.foldl op occ xs+                  where+                    op occ' (_ws2, SCO _sc2 occ2)+                        = DM.difference occ' occ2++    intersectSC+        = intersectSRD intersectSC++    intersectDisplSC d+        = intersectSRD $ intersectDisplSC d++    intersectFuzzySC lb ub+        = intersectSRD $ intersectFuzzySC lb ub++-- ------------------------------------------------------------+--+-- auxiliary functions for ScoredRawDocs++-- | generalized intersection operator for ScoredRawDocs++intersectSRD :: (ScoredOccs -> ScoredOccs -> ScoredOccs)+              -> ScoredRawDocs -> ScoredRawDocs -> ScoredRawDocs+intersectSRD interSRD (SRD xs1) (SRD xs2)+    = srd $ [ (ws1 ++ ws2, interSRD socc1 socc2)+            | (ws1, socc1) <- xs1+            , (ws2, socc2) <- xs2+            ]++-- | smart constructor for ScoredRawDoc removing empty entries++srd :: [([Word], ScoredOccs)] -> ScoredRawDocs+srd+    = SRD . L.filter (not . nullSC . snd)++filterByDocSet :: UnScoredDocs -> ScoredRawDocs -> ScoredRawDocs+filterByDocSet (UDS ds) (SRD xs)+    = SRD $ concatMap filterDocs xs+      where+        filterDocs (ws, SCO sc occ)+            | Occ.null occ'+                = []+            | otherwise+                = [(ws, SCO sc occ')]+            where+              occ' = DM.filterWithKey p occ+                  where+                    p k _v = k `DS.member` ds++-- ------------------------------------------------------------++-- | Add the Context dimension to a scored result++newtype ScoredCx a+    = SCX (Map Context a)+      deriving (Show)++instance Functor ScoredCx where+    fmap f (SCX m) = SCX $ M.map f m++instance Monoid a => Monoid (ScoredCx a) where+    mempty+        = SCX M.empty+    mappend (SCX m1) (SCX m2)+        = SCX $ M.unionWith (<>) m1 m2++instance ScoredResult a => ScoredResult (ScoredCx a) where+    boost b (SCX m)+        = SCX $ M.map (boost b) m++    nullSC (SCX m)+        = M.null m++    differenceSC+        = binopSCX differenceSC++    intersectSC+        = binopSCX intersectSC++    intersectDisplSC d+        = binopSCX $ intersectDisplSC d++    intersectFuzzySC lb ub+        = binopSCX $ intersectFuzzySC lb ub+++-- | The final op for a search result: boost the partial results of the contexts+-- with the context weights from the schema and aggregate them+-- by throwing away the contexts++boostAndAggregateCx :: ScoredResult a => ScoredContexts -> ScoredCx a -> a+boostAndAggregateCx (SWS sm) (SCX m)+    = M.foldlWithKey op mempty m+      where+        op res k x+            = boost b x <> res+              where+                b = fromMaybe defScore $ M.lookup k sm++contextWeights :: Schema -> ScoredContexts+contextWeights s+    = SWS $ M.map cxWeight s++-- ------------------------------------------------------------+--+-- auxiliary functions for scored context results++binopSCX :: ScoredResult a => (a -> a -> a) -> (ScoredCx a -> ScoredCx a -> ScoredCx a)+binopSCX op (SCX m1) (SCX m2)+    = scx $ M.mapWithKey op' m1+          where+            op' cx1 sr1+                = sr1 `op` sr2+                  where+                    sr2 = fromMaybe mempty $ M.lookup cx1 m2+++-- | smart constructore for ScoredCx removing empty contexts++scx :: ScoredResult a => Map Word a -> ScoredCx a+scx = SCX . M.filter (not . nullSC)++-- ------------------------------------------------------------+--+-- conversions from RawResult into scored results++type CxRawResults = [(Context, RawScoredResult)]++fromCxRawResults :: CxRawResults -> ScoredCx ScoredRawDocs+fromCxRawResults crs+    = -- traceShow ("fromCxRawResults:"::String, crs, res) $+      res+      where+        res = mconcat $ L.map (uncurry $ fromRawResult) crs++fromRawResult :: Context -> RawScoredResult -> ScoredCx ScoredRawDocs+fromRawResult cx rr+    = SCX $ M.singleton cx sr+      where+        sr = SRD $ L.map toScored rr+            where+              toScored (w, (sc, occ))+                  = ([w], SCO sc occ)++limitCxRawResults :: Int -> CxRawResults -> CxRawResults+limitCxRawResults mx+    = L.map (second $ limitRawResult mx)++limitRawResult :: Int -> RawScoredResult -> RawScoredResult+limitRawResult maxDocs rs+    | maxDocs <= 0 = rs+    | otherwise = takeDocs maxDocs rs+    where+      takeDocs _  xs@[]+          = xs+      takeDocs _  xs@[_]+          = xs+      takeDocs mx (r@(_w, (_sc, occ)) : xs)+          = case DM.sizeWithLimit mx occ of+              Nothing -> [r]+              Just s  -> let mx' = mx - s in+                         if mx' <= 0+                            then [r]+                            else r : takeDocs mx' xs++-- | convert a set of scored doc ids into a list of documents containing the score+--+-- This list may be further sorted by score, partitioned into pages or ...++toDocsResult :: (Applicative m, Monad m, DocTable dt) =>+                dt -> ScoredDocs -> m [RankedDoc]+toDocsResult dt (SDS m)+    = mapM toDoc (DM.toList m)+      where+        toDoc (did, sc)+            = (toD . fromJust') <$> Dt.lookup did dt+            where+              toD d'+                  = RD (wght d * sc, d)+                  where+                    d = unwrap d'+        fromJust' (Just x) = x+        fromJust' Nothing  = error "Intermediate.toDocsResult: undefined"+-- ----------------------------------------+-- ranking of documents++-- define a total ordering over documents by taking score and uri into account+-- this is used for ranking (only)+--+-- XXX TODO: maybe move to Common modules, since this type is now the regular+--           return type++newtype RankedDoc = RD {unRD :: (Score, Document)}+  deriving Show++instance Eq RankedDoc where+    (RD (sc1,d1)) == (RD (sc2,d2))+        = sc1 == sc2+          &&+          uri   d1 == uri   d2++instance Ord RankedDoc where+    (RD (sc1,d1)) `compare` (RD (sc2,d2))+        = case sc1 `compare` sc2 of+            EQ -> uri d2 `compare` uri d1+            r  -> r++instance ToJSON RankedDoc where+    toJSON (RD (c,d))+      = addScore $ toJSON d+      where+        addScore (Object hm)+          = Object $ HM.insert "score" (toJSON c) hm+        addScore _+          = error "toJSON rankedDoc: propably a bug introduced with #75"++toDocumentResultPage :: Int -> Int -> [RankedDoc] -> [RankedDoc]+toDocumentResultPage = Q.pageList++-- ----------------------------------------+-- ranking of completions++data RankedWord = RW Score Word+                   deriving Eq++instance Ord RankedWord where+    (RW s1 w1) `compare` (RW s2 w2)+        = case s1 `compare` s2 of+            EQ -> w2 `compare` w1+            r  -> r++toWordsResult :: Int -> ScoredWords -> [(Word, Score)]+toWordsResult len (SWS m)+    = map (\ (RW s w) -> (w, s))+      . Q.toList 0 len+      . M.foldWithKey (\ w s -> Q.insert (RW s w)) (Q.mkQueue len)+      $ m++-- ------------------------------------------------------------+--+-- aggregating (raw) results for various types of scored results++class Aggregate a b where+    aggregate :: a -> b++-- | allow no aggregation++instance Aggregate a a where+    aggregate = id++-- | aggregate scored docs to a single score by summing up the scores and throw away the DocIds++instance Aggregate ScoredDocs Score where+    aggregate (SDS m)+        = DM.foldr (<>) defScore m+++-- | aggregate scored occurences by counting the positions per doc and boost the+-- result with the score.+--+-- The positions in a doc are thrown away, so all kinds of phrase search become impossible++instance Aggregate ScoredOccs ScoredDocs where+    aggregate (SCO sc occ)+        = SDS $ DM.map toScore occ+          where+            toScore = (sc *) . mkScore . fromIntegral . Pos.size++-- | aggregate scored occurrences to unscored docs by throwing away the score+instance Aggregate ScoredOccs UnScoredDocs where+    aggregate (SCO _sc occ)+        = toUnScoredDocs occ++-- | aggregate scored occurences to a score by aggregating first the positions and snd the doc ids+--+-- used in computing the score of word in completion search++instance Aggregate ScoredOccs Score where+    aggregate = agg2 . agg1+        where+          agg1 :: ScoredOccs -> ScoredDocs+          agg1 = aggregate+          agg2 :: ScoredDocs -> Score+          agg2 = aggregate++-- | aggregate scored raw results by throwing away the word hits and aggregating+-- all document hits by throwing away the positions.+--+-- The function for computing the scores of documents in a query++instance Aggregate ScoredRawDocs ScoredDocs where+    aggregate (SRD xs)+        = L.foldl (<>) mempty+          $ L.map (aggregate . snd) xs++-- | aggregate scored raw results into an unscored result by throwing away+-- the words, scores and occurrences++instance Aggregate ScoredRawDocs UnScoredDocs where+    aggregate (SRD xs)+        = L.foldl (<>) mempty+          $ L.map (aggregate . snd) xs++-- | aggregate the scored raw results by computing the score of all doc per word+--+-- Used in completion search.+-- The sequence of words (in a phrase) is cut to the last word (@L.last@). For this last one+-- the completions are computed.++instance Aggregate ScoredRawDocs ScoredWords where+    aggregate (SRD xs)+        = SWS+          $ L.foldl (\ res (w, sc) -> M.insertWith (+) w sc res) M.empty+          $ L.map (L.last *** aggregate) xs++-- | Lifting aggregation to scored context results++instance Aggregate a b => Aggregate (ScoredCx a) (ScoredCx b) where+    aggregate (SCX m)+        = SCX $ M.map aggregate m++-- ------------------------------------------------------------++-- query operator evaluation++-- | combine a sequence of results from a phrase query into a single result+-- and aggregate this result into a simpler structure,+-- e.g. a @ScoredDocs@ or @ScoredWords@ value+--+-- The arguments must be of this unaggregated from, still containing word+-- positions, else sequences of words are not detected++evalSequence :: (ScoredResult r, Aggregate ScoredRawDocs r) =>+                (ScoredCx ScoredRawDocs -> ScoredCx r) ->+                [ScoredCx ScoredRawDocs] -> ScoredCx r+evalSequence _aggr []+    = mempty+evalSequence aggr [r1]+    = aggr r1+evalSequence aggr (r1 : rs)+    = aggr $ L.foldl op r1 (L.zip [(1::Int)..] rs)+      where+        op acc (d, r2) = intersectDisplSC d acc r2++evalFollow :: (ScoredResult r, Aggregate ScoredRawDocs r) =>+              (ScoredCx ScoredRawDocs -> ScoredCx r) ->+              Int ->+              [ScoredCx ScoredRawDocs] -> ScoredCx r+evalFollow _aggr _d []+    = mempty+evalFollow aggr _d [r1]+    = aggr r1+evalFollow aggr dp (r1 : rs)+    = aggr $ L.foldl op r1 (L.zip [dp, (2 * dp) ..] rs)+      where+        op acc (d, r2) = intersectFuzzySC 1 d acc r2++evalNear :: (ScoredResult r, Aggregate ScoredRawDocs r) =>+            (ScoredCx ScoredRawDocs -> ScoredCx r) ->+            Int ->+           [ScoredCx ScoredRawDocs] -> ScoredCx r+evalNear _aggr _d []+    = mempty+evalNear aggr _d [r1]+    = aggr r1+evalNear aggr dp (r1 : rs)+    = aggr $ L.foldl op r1 (L.zip [dp, (2 * dp) ..] rs)+      where+        op acc (d, r2) = intersectFuzzySC (-d) d acc r2++evalOr, evalAnd, evalAndNot :: ScoredResult a => [a] -> a+evalOr     = evalBinary (<>)+evalAnd    = evalBinary intersectSC+evalAndNot = evalBinary differenceSC++evalBinary :: ScoredResult a => (a -> a -> a) -> [a] -> a+evalBinary _ []+    = mempty+evalBinary _ [r]+    = r+evalBinary op rs+    = L.foldl1 op rs++evalBoost :: ScoredResult a => Score -> a -> a+evalBoost = boost++evalPrim :: Aggregate (ScoredCx ScoredRawDocs) (ScoredCx r) => ScoredCx ScoredRawDocs -> ScoredCx r+evalPrim = aggregate++-- ------------------------------------------------------------
+ src/Hunt/Query/Language/Builder.hs view
@@ -0,0 +1,232 @@++module Hunt.Query.Language.Builder+  (   qWord+    , qWordNoCase+    , qFullWord+    , qFullWordNoCase+    , qPhrase+    , qPhraseNoCase+    , qPrefixPhrase+    , qPrefixPhraseNoCase+    , qRange+    , qAnd+    , qAnds+    , qOr+    , qOrs+    , qAndNot+    , qAndNots+    , qNext+    , qNexts+    , qFollow+    , qFollows+    , qNear+    , qNears+    , setNoCaseSearch+    , setFuzzySearch+    , setContext+    , setContexts+    , setBoost+    , withinContexts    -- deprecated+    , withinContext     -- deprecated+    , withBoost         -- deprecated+    , qContext+    )+where++import           Hunt.Query.Language.Grammar+import           Data.Text                   (Text)+import qualified Data.Text                   as T++import           Hunt.Common.BasicTypes      (Context, Weight)++-- query construction++-- | case sensitive prefix search of a single word++qWord :: Text -> Query+qWord = QWord QCase++-- | case insensitive prefix search of a single word++qWordNoCase :: Text -> Query+qWordNoCase = QWord QNoCase++-- | exact case sensitive search of a single word++qFullWord :: Text -> Query+qFullWord = QFullWord QCase++-- | exact, but case insensitive search of a single word++qFullWordNoCase :: Text -> Query+qFullWordNoCase = QFullWord QNoCase++-- --------------------+--+-- phrase search++qPhrase' :: (Text -> Query) -> Text -> Query+qPhrase' qf t+    = case T.words t of+        [w] -> qf w+        ws  -> qNexts $ map qf ws++-- | exact search of a sequence of space separated words.+-- For each word in the sequence, an exact word search is performed.++qPhrase :: Text -> Query+qPhrase = qPhrase' qFullWord++-- | exact, but case insenitive search of a sequence of space separated words.+-- For each word in the sequence, a word search is performed.++qPhraseNoCase :: Text -> Query+qPhraseNoCase = qPhrase' qFullWordNoCase++-- | prefix search of a sequence of space separated words.+-- For each word in the sequence, a prefix search is performed.++qPrefixPhrase :: Text -> Query+qPrefixPhrase = qPhrase' qWordNoCase++-- | prefix search of a sequence of space separated words.+-- For each word in the sequence, a prefix search is performed.++qPrefixPhraseNoCase :: Text -> Query+qPrefixPhraseNoCase = qPhrase' qWordNoCase++-- --------------------++-- | search a range of words or an intervall for numeric contexts+qRange :: Text -> Text -> Query+qRange = QRange++-- | shortcut for case sensitive context search+qContext :: Context -> Text -> Query+qContext c w = QContext [c] $ QWord QCase w++-- | and query+qAnd :: Query -> Query -> Query+qAnd q1 q2 = qAnds [q1, q2]++--  | multiple @and@ queries. The list must not be emtpy+qAnds :: [Query] -> Query+qAnds = mkAssocSeq And++-- | or query+qOr :: Query -> Query -> Query+qOr q1 q2 = qOrs [q1, q2]++--  | multiple @or@ queries. The list must not be emtpy+qOrs :: [Query] -> Query+qOrs = mkAssocSeq Or++-- | and not query+qAndNot :: Query -> Query -> Query+qAndNot q1 q2 = qAndNots [q1, q2]++--  | multiple @and-not@ queries. The list must not be emtpy+-- TODO handle left associativity++qAndNots :: [Query] -> Query+qAndNots = mkLeftAssocSeq AndNot++-- | neighborhood queries. The list must not be empty+--+-- TODO: a better name for qNext and qNexts, qPhrase is already used++qNext :: Query -> Query -> Query+qNext q1 q2 = qNexts [q1, q2]++qNexts :: [Query] -> Query+qNexts = mkAssocSeq Phrase++qFollow :: Int -> Query -> Query -> Query+qFollow d q1 q2 = qFollows d [q1, q2]++qFollows :: Int -> [Query] -> Query+qFollows d = mkAssocSeq (Follow d)++qNear :: Int -> Query -> Query -> Query+qNear d q1 q2 = qNears d [q1, q2]++qNears :: Int -> [Query] -> Query+qNears d = mkAssocSeq (Near d)++collectAssocs :: BinOp -> [Query] -> [Query]+collectAssocs op qs+    = concatMap subqs qs+    where+      subqs (QSeq op' qs')+          | op == op'+              = qs'+      subqs q'+          = [q']++mkAssocSeq :: BinOp -> [Query] -> Query+mkAssocSeq op qs+    = remSingle $ QSeq op (collectAssocs op qs)++mkLeftAssocSeq :: BinOp -> [Query] -> Query+mkLeftAssocSeq op qs+    = remSingle $ QSeq op qs'+    where+      qs' = case qs of+              (QSeq op' qs1 : qs2)+                  | op == op'+                      -> qs1 ++ qs2+              _       -> qs++remSingle :: Query -> Query+remSingle (QSeq _ [q])+    = q+remSingle q+    = q+++-- ------------------------------------------------------------+-- configure simple search queries++-- | case insensitve search, only sensible for word and phrase queries++setNoCaseSearch :: Query -> Query+setNoCaseSearch (QWord     _ w) = QWord     QNoCase w+setNoCaseSearch (QFullWord _ w) = QFullWord QNoCase w+setNoCaseSearch (QPhrase   _ w) = QPhrase   QNoCase w+setNoCaseSearch q             = q++-- | fuzzy search, only sensible for word and phrase queries++setFuzzySearch :: Query -> Query+setFuzzySearch (QWord     _ w) = QWord     QFuzzy w+setFuzzySearch (QFullWord _ w) = QFullWord QFuzzy w+setFuzzySearch (QPhrase   _ w) = QPhrase   QFuzzy w+setFuzzySearch q             = q++-- | restrict search to list of contexts++setContexts :: [Context] -> Query -> Query+setContexts = QContext++withinContexts :: [Context] -> Query -> Query+withinContexts = QContext+{-# DEPRECATED withinContexts "Don't use this, use setContexts" #-}++-- | restrict search to a single context++setContext :: Context -> Query -> Query+setContext cx = withinContexts [cx]++withinContext :: Context -> Query -> Query+withinContext cx = setContexts [cx]+{-# DEPRECATED withinContext "Don't use this, use setContext" #-}+++-- | boost the search results by a factor++setBoost :: Weight -> Query -> Query+setBoost = QBoost++withBoost :: Weight -> Query -> Query+withBoost = QBoost+{-# DEPRECATED withBoost "Don't use this, use setBoost" #-}
+ src/Hunt/Query/Language/Grammar.hs view
@@ -0,0 +1,378 @@+{-# LANGUAGE OverloadedStrings #-}++-- ----------------------------------------------------------------------------+{- |+  The query language.++  'Query' specifies the complete grammar.++  "Hunt.Query.Language.Parser" provides a parser for plain text queries.+-}+-- ----------------------------------------------------------------------------++module Hunt.Query.Language.Grammar+    ( -- * Query data types+      Query (..)+    , BinOp (..)+    , TextSearchType (..)+    , escapeChar+    , notWordChar++    -- * Optimizing+    , optimize+    , checkWith+    , extractTerms+    -- * Pretty printing+    , printQuery+    )+where++import           Control.Applicative+import           Control.Monad++import           Data.Aeson+import           Data.Binary+import           Data.Text              (Text)+import qualified Data.Text              as T+import           Data.Text.Binary       ()++import           Hunt.Common.BasicTypes as BTy++import           Text.Read              (readMaybe)++-- ------------------------------------------------------------++-- TODO: the constructors QPhrase and QBinary can be removed+-- they can be represented by QFullWord and QSeq.+--+-- Currently these operators are transformed during query evaluation+-- on the fly into QFullWord and QSeq.++-- | The query language.+data Query+  = QWord     TextSearchType Text  -- ^ prefix search for a word+  | QFullWord TextSearchType Text  -- ^ search for a complete word+  | QPhrase   TextSearchType Text  -- ^ Phrase search.+  | QContext  [Context] Query      -- ^ Restrict a query to a list of contexts.+  | QBinary   BinOp Query Query    -- ^ Combine two queries with a binary operation.+  | QSeq      BinOp [Query]+  | QBoost    Weight Query         -- ^ Weight for query.+  | QRange    Text Text            -- ^ Range query.+  deriving (Eq, Show)++-- | The search opeation.+data TextSearchType+  = QCase   -- ^ Case-sensitive search.+  | QNoCase -- ^ Case-insensitive search.+  | QFuzzy  -- ^ Fuzzy search. See "Hunt.Query.Fuzzy" for details.+            --   The query processor allows additional configuration with+            --   'Hunt.Query.Processor.ProcessConfig'.+  deriving (Eq, Show)++-- | A binary operation.+data BinOp+  = And        -- ^ Intersect two queries.+  | Or         -- ^ Union two queries.+  | AndNot     -- ^ Filter a query by another.+  | Phrase     -- ^ Search for a sequence of words+  | Follow Int -- ^ Search a word followed another word within a distance+  | Near   Int -- ^ search a word followed or preceded another word within a distance+  deriving (Eq, Show)++-- ------------------------------------------------------------+-- JSON instances+-- ------------------------------------------------------------++instance ToJSON Query where+  toJSON o = case o of+    QWord op w        -> object . ty "word"     $ [ "op" .= op, "word"   .= w ]+    QFullWord op w    -> object . ty "fullword" $ [ "op" .= op, "word"   .= w ]+    QPhrase op s      -> object . ty "phrase"   $ [ "op" .= op, "phrase" .= s ]+    QContext c q      -> object . ty "context"  $ [ "contexts" .= c , "query" .= q ]+    QBinary op q1 q2  -> object . ty' op        $ [ "query1" .= q1, "query2" .= q2 ]+    QSeq    op qs     -> object . ty "seq"      $ [ "op" .= op, "args" .= qs ]+    QBoost  w q       -> object . ty "boost"    $ [ "weight" .= w, "query" .= q ]+    QRange l u        -> object . ty "range"    $ [ "lower" .= l, "upper" .= u ]+    where+    ty' t = (:) ("type" .= t)+    ty  t = ty' (t :: Text)++instance FromJSON Query where+  parseJSON (Object o) = do+    t <- o .: "type"+    case (t :: Text) of+      "word"+          -> QWord     <$> (o .: "op") <*> (o .: "word")+      "fullword"+          -> QFullWord <$> (o .: "op") <*> (o .: "word")+      "phrase"+          -> QPhrase   <$> (o .: "op") <*> (o .: "phrase")+      "context"+          -> QContext  <$> (o .: "contexts") <*> (o .: "query")+      "boost"+          -> QBoost    <$> (o .: "weight") <*> (o .: "query")+      "range"+          -> QRange    <$> (o .: "lower") <*> (o .: "upper")+      "and"+          -> bin And+      "or"+          -> bin Or+      "and not"+          -> bin AndNot+      "seq"+          -> QSeq      <$> (o .: "op") <*> (o .: "args")+      _   -> mzero+    where+    bin op+        = QBinary op   <$> (o .: "query1") <*> (o .: "query2")+  parseJSON _ = mzero+++instance ToJSON TextSearchType where+  toJSON o = case o of+    QCase   -> "case"+    QNoCase -> "nocase"+    QFuzzy  -> "fuzzy"++instance FromJSON TextSearchType where+  parseJSON (String s)+    = case s of+      "case"   -> return QCase+      "nocase" -> return QNoCase+      "fuzzy"  -> return QFuzzy+      _         -> mzero+  parseJSON _ = mzero++instance ToJSON BinOp where+  toJSON o = case o of+    And      -> "and"+    Or       -> "or"+    AndNot   -> "and not"+    Phrase   -> "phrase"+    Follow d -> String $ "follow " <> T.pack (show d)+    Near   d -> String $ "near "   <> T.pack (show d)++instance FromJSON BinOp where+  parseJSON (String s)+    = case T.words s of+      ["and"]        -> return And+      ["or"]         -> return Or+      ["and", "not"] -> return AndNot+      ["phrase"]     -> return Phrase+      ["follow", d]  -> maybe mzero (return . Follow) . readMaybe . T.unpack $ d+      ["near", d]    -> maybe mzero (return . Near  ) . readMaybe . T.unpack $ d+      _              -> mzero+  parseJSON _ = mzero++-- ------------------------------------------------------------+-- Binary instances+-- ------------------------------------------------------------++instance Binary Query where+  put (QWord op s)       = put (0 :: Word8) >> put op >> put s+  put (QFullWord op s)   = put (7 :: Word8) >> put op >> put s+  put (QPhrase op s)     = put (1 :: Word8) >> put op >> put s+  put (QContext c q)     = put (2 :: Word8) >> put c  >> put q+  put (QBinary o q1 q2)  = put (4 :: Word8) >> put o  >> put q1 >> put q2+  put (QSeq    o qs)     = put (8 :: Word8) >> put o  >> put qs+  put (QBoost w q)       = put (5 :: Word8) >> put w  >> put q+  put (QRange l u)       = put (6 :: Word8) >> put l  >> put u++  get = do+    tag <- getWord8+    case tag of+      0 -> QWord     <$> get <*> get+      7 -> QFullWord <$> get <*> get+      1 -> QPhrase   <$> get <*> get+      2 -> QContext  <$> get <*> get+      4 -> QBinary   <$> get <*> get <*> get+      8 -> QSeq      <$> get <*> get+      5 -> QBoost    <$> get <*> get+      6 -> QRange    <$> get <*> get+      _ -> fail "Error while decoding Query"+++instance Binary TextSearchType where+  put QCase   = put (0 :: Word8)+  put QNoCase = put (1 :: Word8)+  put QFuzzy  = put (2 :: Word8)++  get = do+    tag <- getWord8+    case tag of+      0 -> return QCase+      1 -> return QNoCase+      2 -> return QFuzzy+      _ -> fail "Error while decoding BinOp"++instance Binary BinOp where+  put And        = put (0 :: Word8)+  put Or         = put (1 :: Word8)+  put AndNot     = put (2 :: Word8)+  put Phrase     = put (3 :: Word8)+  put (Follow d) = put (4 :: Word8) >> put d+  put (Near   d) = put (5 :: Word8) >> put d++  get = do+    tag <- getWord8+    case tag of+      0 -> return And+      1 -> return Or+      2 -> return AndNot+      3 -> return Phrase+      4 -> Follow <$> get+      5 -> Near   <$> get+      _ -> fail "Error while decoding BinOp"++-- ------------------------------------------------------------++-- | Characters that cannot occur in a word (and have to be escaped).+notWordChar :: String+notWordChar = escapeChar : "\"')([]^ \n\r\t"++-- | The character an escape sequence starts with.+escapeChar :: Char+escapeChar = '\\'++-- | Minor query optimizations.+--+--   /Note/: This can affect the ranking.+optimize :: Query -> Query+-- Same prefix in AND query (case-insensitive)+optimize q@(QBinary And (QWord QNoCase q1) (QWord QNoCase q2))+  | T.toLower q1 `T.isPrefixOf` T.toLower q2 = QWord QNoCase q2+  | T.toLower q2 `T.isPrefixOf` T.toLower q1 = QWord QNoCase q1+  | otherwise = q+-- Same prefix in AND query (case-sensitive)+optimize q@(QBinary And (QWord QCase q1) (QWord QCase q2))+  | q1 `T.isPrefixOf` q2 = QWord QCase q2+  | q2 `T.isPrefixOf` q1 = QWord QCase q1+  | otherwise = q+-- Same prefix in OR query (case-insensitive)+optimize q@(QBinary Or (QWord QNoCase q1) (QWord QNoCase q2))+  | T.toLower q1 `T.isPrefixOf` T.toLower q2 = QWord QNoCase q1+  | T.toLower q2 `T.isPrefixOf` T.toLower q1 = QWord QNoCase q2+  | otherwise = q+-- Same prefix in OR query (case-sensitive)+optimize q@(QBinary Or (QWord QCase q1) (QWord QCase q2))+  | q1 `T.isPrefixOf` q2 = QWord QCase q1+  | q2 `T.isPrefixOf` q1 = QWord QCase q2+  | otherwise = q+-- recursive application+optimize (QBinary And    q1 q2) = QBinary And    (optimize q1) (optimize q2)+optimize (QBinary Or     q1 q2) = QBinary Or     (optimize q1) (optimize q2)+optimize (QBinary AndNot q1 q2) = QBinary AndNot (optimize q1) (optimize q2)+optimize (QContext cs q)        = QContext cs (optimize q)+optimize (QBoost w q)           = QBoost w (optimize q)++optimize q                      = q++-- | Check if the query arguments comply with some custom predicate.+checkWith                         :: (Text -> Bool) -> Query -> Bool+checkWith f (QWord _ s)           = f s+checkWith f (QFullWord _ s)       = f s+checkWith f (QPhrase _ s)         = f s+checkWith f (QBinary _ q1 q2)     = checkWith f q1 && checkWith f q2+checkWith f (QSeq _ qs)           = and $ map (checkWith f) qs+checkWith f (QContext _ q)        = checkWith f q+checkWith f (QBoost _ q)          = checkWith f q+checkWith f (QRange s1 s2)        = f s1 && f s2++-- | Returns a list of all terms in the query.+extractTerms                      :: Query -> [Text]+extractTerms (QWord _ s)           = [s]+extractTerms (QFullWord _ s)       = [s]+extractTerms (QContext _ q)        = extractTerms q+extractTerms (QBinary _ q1 q2)     = extractTerms q1 ++ extractTerms q2+extractTerms _                     = []++-- ------------------------------------------------------------++-- | Renders a text representation of a Query.++printQuery :: Query -> Text+printQuery (QWord QNoCase w)+    = printWord w++printQuery (QWord QCase w)+    = "!" <> printWord w++printQuery (QWord QFuzzy w)+    = "~" <> printWord w++printQuery (QFullWord QNoCase w)+    = printPhrase w++printQuery (QFullWord QCase w)+    = "!" <> printPhrase w++printQuery (QFullWord QFuzzy w)+    = "~" <> printPhrase w++printQuery (QPhrase _ w)+    = printPhrase w++printQuery (QContext [] w)+    = printQPar w++printQuery (QContext cs' w)+    = printCs <> ":(" <> (printQPar w) <> ")"+      where+        printCs = foldr1 (\l r -> l <> "," <> r) cs'++printQuery (QBinary o l r)+    = (printQPar l) <> (printOp o) <> (printQPar r)++printQuery (QSeq _ [])+    = ""+printQuery (QSeq _ [q])+    = printQuery q+printQuery (QSeq o qs)+    = foldr1 (\ res arg -> res <> printOp o <> arg) $+      map printQPar qs++printQuery (QBoost w q)+    = (printQPar q) <> "^" <> (T.pack $ show $ unScore $ toDefScore $ w)++printQuery (QRange l u)+    = "[" <> l <> " TO " <> u <> "]"++printOp :: BinOp -> Text+printOp And        = " " -- the token AND is not required.+printOp Or         = " OR "+printOp AndNot     = " AND NOT "+printOp Phrase     = " ++ "+printOp (Follow d) = " FOLLOW " <> (T.pack $ show d) <> " "+printOp (Near   d) = " NEAR "   <> (T.pack $ show d) <> " "++-- | Maybe render paranthesis.+printQPar :: Query -> Text+printQPar q@QWord{}     = printQuery q+printQPar q@QFullWord{} = printQuery q+printQPar q@QPhrase{}   = printQuery q+printQPar q@QRange{}    = printQuery q+printQPar q@QContext{}  = printQuery q+printQPar q             = "(" <> (printQuery q) <> ")"++printPhrase :: Text -> Text+printPhrase w+    = "\"" <> escapeWord toBeQuoted w <> "\""+    where+      toBeQuoted = (== '\"')++printWord :: Text -> Text+printWord w+    | T.any toBeQuoted w = "'" <> escapeWord (== '\'') w <> "'"+    | otherwise          = w+    where+      toBeQuoted c = elem c $ notWordChar++escapeWord :: (Char -> Bool) -> Text -> Text+escapeWord p t+    = T.concatMap esc t+      where+        esc c+            | p c = T.pack ('\\' : c : [])+            | otherwise = T.singleton c++-- ------------------------------------------------------------
+ src/Hunt/Query/Language/Parser.hs view
@@ -0,0 +1,322 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC  -fno-warn-unused-do-bind #-}++-- ----------------------------------------------------------------------------+{- |+  Module     : Hunt.Query.Language.Parser+  Copyright  : Copyright (C) 2007, 2008 Timo B. Huebel+  License    : MIT++  Maintainer : Timo B. Huebel (tbh@holumbus.org)+  Stability  : experimental+  Portability: portable+  Version    : 0.2++  The Hunt query parser, based on the famous Parsec library.++  The parser implements a default syntax for the query grammar which exposes+  all possible query types and operators to the user.++  Syntax:++  [@AND@, @OR@, @AND NOT@] = combinatory queries++  [@!w@]                   = case sensitive prefix query e.g.: @!car@ or @!Car@++  [@~w@]                   = fuzzy word query            e.g.: @~car@ or @~cra@++  [@\"...\"@]              = phrase query, performs an exact search for a single word++  [@(...)@]                = brackets++  [@c:w@]                  = context sensitive queries   e.g.: @(who:Rudi Voeller)@++  [@c1,c2:w@]              = multi context queries       e.g.: @(content,who,title:Rudi Voeller)@++  [@\[... TO ...\]@]       = range queries               e.g.: @[2014-02-10 TO 2012-02-16]@++  [@w\^b@]                 = query boosting              e.g.: @toList OR toAscList^1.5@+-}+-- ----------------------------------------------------------------------------++module Hunt.Query.Language.Parser+  (+  -- * Parsing+  parseQuery+  )+where++import           Control.Applicative         hiding (many, (<|>))++import           Data.Text                   (Text)+import qualified Data.Text                   as T++import           Text.Parsec+import           Text.Parsec.String++import           Hunt.Query.Language.Builder+import           Hunt.Common.BasicTypes        (mkScore)+import           Hunt.Query.Language.Grammar++-- ------------------------------------------------------------++-- | Parse a query using the default syntax provided by the Hunt framework.+parseQuery :: String -> Either Text Query+parseQuery = result . parse query ""+  where+  result (Left err) = Left (T.pack . show $ err)+  result (Right q)  = Right q++-- | A query may always be surrounded by whitespace+query :: Parser Query+query+    = do spaces+         res <- orQuery'+         spaces >> eof+         return res++orQuery' :: Parser Query+orQuery'+    = do q1 <- andQuery'+         qs <- many (orOp1 >> andQuery')+         return $ qOrs (q1 : qs)+    where+      orOp1+          = try orOp'+          where+            orOp' = spaces >> string "OR" >> spaces1++andQuery' :: Parser Query+andQuery'+    = do q1 <- neighborQuery+         qs <- many $+               do op <- andOp1+                  q  <- neighborQuery+                  return (op, q)+         return $ foldl (\ res (op', q') -> op' res q') q1 qs+    where+      andOp1+          = try andNotOp'+            <|> try andOp'+          where+            andNotOp'+                = do spaces >> string "AND" >> spaces >> string "NOT" >> spaces1+                     return qAndNot+            andOp' = do spaces >> string "AND" >> spaces1+                        return qAnd+++neighborQuery :: Parser Query+neighborQuery+    = do q1 <- contextSeqQuery+         qs <- many $+               do op <- neiOp+                  q  <- contextSeqQuery+                  return (op, q)+         return $ foldl (\ res (op', q') -> op' res q') q1 qs+    where+      neiOp+          = try nextOp+            <|> try nearOp+            <|> try followOp+          where+            nextOp+                = do spaces >> string "++" >> spaces1+                     return qNext+            nearOp+                = do spaces >> string "NEAR" >> spaces+                     d <- read <$> many1 digit+                     spaces1+                     return $ qNear d++            followOp+                = do spaces >> string "FOLLOW" >> spaces+                     d <- read <$> many1 digit+                     spaces1+                     return $ qNear d++contextSeqQuery :: Parser Query+contextSeqQuery+    = do q1 <- boostQuery+         qs <- many $+               try (spaces1 >> boostQuery)+         return $ foldl qAnd q1 qs++boostQuery :: Parser Query+boostQuery+    = do q <- contextQuery+         tryBoost q+++-- | Parse a context query.+contextQuery :: Parser Query+contextQuery+    = do cs <- try contextSpec <|> return []+         q  <- primaryQuery+         case cs of+           [] -> return q+           _  -> return (QContext cs q)+    where+      contextSpec+          = do cs <- contexts+               spaces >> char ':' >> spaces+               return cs++primaryQuery :: Parser Query+primaryQuery+    = parQuery+      <|>+      rangeQuery+      <|>+      caseQuery+      <|>+      fuzzyQuery+      <|>+      noCaseQuery++-- | Parse a query surrounded by parentheses.+parQuery :: Parser Query+parQuery+    = do char '(' >> spaces+         q <- orQuery'+         spaces >> char ')'+         return q++-- | Parse a range query.+rangeQuery :: Parser Query+rangeQuery+    = do char '[' >> spaces+         l <- word+         spaces1 >> string "TO" >> spaces1+         u <- word+         spaces >> char ']' >> spaces+         return $ QRange (T.pack l) (T.pack u)++-- | Parse a case-sensitive query.+caseQuery :: Parser Query+caseQuery+    = do char '!' >> spaces+         ( phraseQuery qPhrase+           <|>+           wordQuery qWord+           <|>+           quotedWordQuery qWord )++-- | Parse a fuzzy query.+fuzzyQuery :: Parser Query+fuzzyQuery+    =do char '~' >> spaces+        ( wordQuery (setFuzzySearch . qWord)+          <|>+          quotedWordQuery (setFuzzySearch . qWord) )++noCaseQuery :: Parser Query+noCaseQuery+    = phraseQuery qPhraseNoCase+      <|>+      quotedWordQuery qWordNoCase+      <|>+      wordQuery qPrefixPhraseNoCase++-- | Parse a word query.+wordQuery :: (Text -> Query) -> Parser Query+wordQuery c = word >>= return . c . T.pack++quotedWordQuery :: (Text -> Query) -> Parser Query+quotedWordQuery c = quotedWord >>= return . c . T.pack++-- | Parse a phrase query.+phraseQuery :: (Text -> Query) -> Parser Query+phraseQuery c = phrase >>= return . c . T.pack++-- | Parse a word.+word :: Parser String+word = try $+       do w <- many1 (escapedChar <|> wordChar)+          if w `elem` ["OR", "AND", "++", "NEAR", "FOLLOW"]+            then parserZero+            else return w+    where+      wordChar :: Parser Char+      wordChar = noneOf notWordChar++-- | Parse an escape sequence. @\@ followed by the character, e.g. @\"@.+escapedChar :: Parser Char+escapedChar = char escapeChar *> decodeChar++-- | Parse a single valid escape character, e.g. @"@.+decodeChar :: Parser Char+decodeChar = choice (zipWith decode notWordChar notWordChar)+    where decode c r = r <$ char c++escaped :: Char -> Parser Char+escaped c+    = do char escapeChar+         (char c <|> return escapeChar)++-- | Parse a phrase.+phrase :: Parser String+phrase+    = do char '"'+         p <- many1 phraseChar+         char '"'+         return p+    where+      phraseChar+          = escaped '\"' <|> noneOf "\""++quotedWord :: Parser String+quotedWord+    = do char '\''+         p <- many1 quotedWordChar+         char '\''+         return p+    where+      quotedWordChar+          = escaped '\'' <|> noneOf "'"++-- | Parse a boosted query.+tryBoost :: Query -> Parser Query+tryBoost q = try boost <|> return q+  where+  boost = do+          char '^'+          b <- simplePositiveFloat+          return (QBoost (mkScore b) q)+++-- | Parse a list of contexts.+contexts :: Parser [Text]+contexts = context `sepBy1` char ','++-- | Parse a context.+context :: Parser Text+context = do spaces+             c <- many1 alphaNum+             spaces+             return (T.pack c)++-- | Parse at least on white space character.+spaces1 :: Parser ()+spaces1 = skipMany1 space++-- | Parse a simple positive number.+simplePositiveNumber :: Parser String+simplePositiveNumber = many1 digit++-- | Parse a simple positive float. The decimal point with following numbers is optional.+simplePositiveFloat :: Parser Float+simplePositiveFloat = fmap read $ simplePositiveNumber <++> decimal+  where decimal  = option "" $ char '.' <:> simplePositiveNumber++-- ------------------------------------------------------------++-- |Applicative concat @(++)@.+(<++>) :: Applicative f => f [a] -> f [a] -> f [a]+(<++>) a b = (++) <$> a <*> b++-- Applicative cons @(:)@.+(<:>) :: Applicative f => f a -> f [a] -> f [a]+(<:>) a b = (:) <$> a <*> b++-- ------------------------------------------------------------
+ src/Hunt/Query/Processor.hs view
@@ -0,0 +1,661 @@+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE TypeFamilies               #-}++-- ----------------------------------------------------------------------------+{- |+  The query processor to perform 'Query's.++  'processQuery' executes the query and generates the unranked result.+  The result can be ranked with the default 'Hunt.Query.Ranking.rank' function.+-}+-- ----------------------------------------------------------------------------++module Hunt.Query.Processor+    ( processQueryScoredDocs+    , processQueryUnScoredDocs+    , processQueryScoredWords+    , initProcessor++    , ProcessConfig (..)+    , ProcessEnv+    )++where++import           Control.Applicative+import           Control.Monad.Error+import           Control.Monad.Reader++import           Data.Binary                 (Binary)+import qualified Data.Binary                 as Bin+import           Data.Default+import qualified Data.List                   as L+import qualified Data.Map                    as M+import           Data.Maybe+import           Data.Text                   (Text)+import qualified Data.Text                   as T++import           Hunt.Common+import           Hunt.ContextIndex           (ContextMap)+import qualified Hunt.ContextIndex           as CIx+import           Hunt.Interpreter.Command    (CmdError (..))+import           Hunt.Query.Fuzzy            (FuzzyConfig)+import           Hunt.Query.Intermediate+import           Hunt.Query.Language.Grammar+import           Hunt.Utility                (showText)++import qualified System.Log.Logger           as Log++-- import           Debug.Trace++-- ------------------------------------------------------------+-- Logging+-- ------------------------------------------------------------++-- | Name of the module for logging purposes.+modName :: String+modName = "Hunt.Query.Processor"++-- | Log a message at 'DEBUG' priority.+debugM :: String -> IO ()+debugM = Log.debugM modName++-- ------------------------------------------------------------+-- Configuration and state for the query processor+-- ------------------------------------------------------------++-- | Query processor configuration.+data ProcessConfig+    = ProcessConfig+      { fuzzyConfig   :: ! FuzzyConfig -- ^ The configuration for fuzzy queries.+      , optimizeQuery :: ! Bool        -- ^ Optimize the query before processing (default: @False@).+      , wordLimit     :: ! Int         -- ^ The maximum number of words used from a prefix. @0@ = no limit (default: @100@).+      , docLimit      :: ! Int         -- ^ The maximum number of documents taken into account. @0@ = no limit (default: @500@).+      }++-- ------------------------------------------------------------++instance Default ProcessConfig where+    def = ProcessConfig def False 100 500++-- ------------------------------------------------------------++instance Binary ProcessConfig where+    put (ProcessConfig fc o l d)+        = Bin.put fc >> Bin.put o >> Bin.put l >> Bin.put d+    get+        = ProcessConfig <$> Bin.get <*> Bin.get <*> Bin.get <*> Bin.get++-- ------------------------------------------------------------++-- | The internal state of the query processor.+data ProcessEnv+    = ProcessEnv+      { psConfig   :: ! ProcessConfig  -- ^ The configuration for the query processor.+      , psContexts :: ! [Context]      -- ^ The current list of contexts.+      , psIndex    ::   ContextMap     -- ^ The index to search.+      }++-- ------------------------------------------------------------+-- Processor monad+-- ------------------------------------------------------------++type QueryIndex+    = ContextMap++-- | the processor monad+newtype ProcessorT m a+    = PT { runProcessor :: ReaderT ProcessEnv (ErrorT CmdError m) a+         }+      deriving (Applicative, Monad, MonadIO, Functor, MonadReader ProcessEnv, MonadError CmdError)++instance MonadTrans ProcessorT where+    lift = PT . lift . lift++type Processor+    = ProcessorT IO++-- ------------------------------------------------------------+-- Helper+-- ------------------------------------------------------------++queryError ::   Int -> Text -> Processor a+queryError n msg+    = throwError $ ResError n msg++getContexts ::   Processor [Context]+getContexts+    = asks psContexts++getIx :: Processor QueryIndex+getIx+    = asks psIndex++getSchema :: Processor Schema+getSchema+    = getIx >>= return . (M.map fst) . CIx.cxMap++-- | Get the schema associated with that context/index.+--+--   /Note/: This fails if the schema does not exist.++getContextSchema ::   Context -> Processor ContextSchema+getContextSchema c+    = do schema <- getSchema+         case M.lookup c schema of+           Just cs -> return cs+           _       -> queryError 420 ("Context does not exist in schema: " <> c)+++-- | Normalizes the search value with respect to the schema context type.+--   First runs the validator that throws an error for invalid values,+--   then runs the normalizers associated with the context.++normQueryCx :: Context -> Text -> Processor (Maybe Text)+normQueryCx c t+    = do s <- getContextSchema c+         -- apply context type validator+         if (validate . ctValidate . cxType $ s) t+           then+               do liftIO . debugM . debugMsg $ s+                  -- apply context schema normalizer+                  return . Just . norm $ s+           else+               return Nothing+    where+      norm s+          = normalize' (cxNormalizer s) t++      debugMsg s+          = T.unpack $ T.concat [ "query normalizer: ", c, ": [", t, "=>", norm s, "]"]++-- | Initialize the state of the processor.+initProcessor :: ProcessConfig -> QueryIndex -> ProcessEnv+initProcessor cfg ix+    = ProcessEnv cfg cxs ix+    where+      s = CIx.mapToSchema ix+      cxs = filter (\c -> fromMaybe False $ M.lookup c s >>= return . cxDefault)+            $ CIx.contexts ix++-- ------------------------------------------------------------++processQueryUnScoredDocs :: ProcessEnv -> Query -> IO (Either CmdError UnScoredDocs)+processQueryUnScoredDocs = processQueryScoredResult evalUnScoredDocs++-- | evaluate a query into a UnScoredDocs result+--+-- all info about contexts, words and positions and the score of docs+-- are removed by the aggregation.+--+-- This evaluator is called by commands which need to compute just a set of documents,+-- e.g. DeleteByQuery. When calling evalUnScoredDocs the 'ProcessEnv' value+-- should be configured such that the limit for document to taken into account+-- is set to infinity (represented as @0@ in the config), else the result set+-- may not be complete.+--+-- In that case it becomes easy to build a query witch acts as a denial of service+-- attack, because the intermediate results become too large to be processed.+-- So these queries must be used in applications rather carefully, e.g. a user should+-- not be able to construct these types of queries by filling in some input fields in a web interface.++evalUnScoredDocs :: Query -> Processor UnScoredDocs+evalUnScoredDocs q+    | isPrimaryQuery q+        = do res <- forallCx (evalPrimary q)+             aggregateToScoredResult res++evalUnScoredDocs (QRange lb ub)+    = do res <- forallCx (evalRange lb ub)+         aggregateToScoredResult res++evalUnScoredDocs (QSeq op qs)+    | isLocalCxOp op+        = do res <- forallCxLocal+                    ( evalSeq' op                     -- do the position aware operation+                      <$> mapM evalScoredRawDocs qs ) -- switch to the raw evaluator due to positions+             aggregateToScoredResult res              -- and aggregate res to UnScoredDocs+    | otherwise+        = evalSeq op                                  -- do the result combination+          <$> mapM evalUnScoredDocs qs                  -- for the args stay in evaluator++evalUnScoredDocs (QContext cxs q)+    = withCxs cxs $ evalUnScoredDocs q++evalUnScoredDocs (QBoost _w q)+    = evalUnScoredDocs q++evalUnScoredDocs q@QPhrase{}              -- QPhrase is transformed into QFullWord or QSeq Phrase+    = normQuery q >>= evalUnScoredDocs++evalUnScoredDocs q@QBinary{}              -- QBin is transformed into QSeq+    = normQuery q >>= evalUnScoredDocs++evalUnScoredDocs q+    = queryEvalError q++-- ------------------------------------------------------------++processQueryScoredDocs :: ProcessEnv -> Query -> IO (Either CmdError ScoredDocs)+processQueryScoredDocs = processQueryScoredResult evalScoredDocs'++-- | evaluate a query into a ScoredDocs result+--+-- all info about contexts, words and positions is removed by the aggregation,+-- just a set of DocIds and associated scores is computed++evalScoredDocs :: Query -> Processor ScoredDocs+evalScoredDocs q+    | isPrimaryQuery q+        = do res <- forallCx (evalPrimary q)+             aggregateToScoredResult res++evalScoredDocs (QRange lb ub)+    = do res <- forallCx (evalRange lb ub)+         aggregateToScoredResult res++evalScoredDocs (QSeq op qs)+    | isLocalCxOp op+        = do res <- forallCxLocal+                    ( evalSeq' op                     -- do the position aware operation+                      <$> mapM evalScoredRawDocs' qs ) -- switch to the raw evaluator due to positions+             aggregateToScoredResult res                -- and aggregate res to ScoredDocs+    | otherwise+        = evalSeq op                                  -- do the result combination+          <$> mapM evalScoredDocs' qs                  -- for the args stay in evaluator++evalScoredDocs (QContext cxs q)+    = withCxs cxs $ evalScoredDocs' q++evalScoredDocs (QBoost w q)+    = boost w <$> evalScoredDocs' q++evalScoredDocs q@QPhrase{}              -- QPhrase is transformed into QFullWord or QSeq Phrase+    = normQuery q >>= evalScoredDocs++evalScoredDocs q@QBinary{}              -- QBin is transformed into QSeq+    = normQuery q >>= evalScoredDocs++evalScoredDocs q+    = queryEvalError q++-- --------------------+-- {- switch off trace++evalScoredDocs' :: Query -> Processor ScoredDocs+evalScoredDocs' = evalScoredDocs+{-# INLINE evalScoredDocs' #-}++-- -}+{- switch on trace the evaluation++evalScoredDocs' :: Query -> Processor ScoredDocs+evalScoredDocs' q = trc <$> evalScoredDocs q+    where+      trc res = traceShow ("evalScoredDocs: "::String,q  ) $+                traceShow ("evalScoredDocs: "::String,res) $ res+-- -}+-- ------------------------------------------------------------++processQueryScoredWords :: ProcessEnv -> Query -> IO (Either CmdError ScoredWords)+processQueryScoredWords = processQueryScoredResult evalScoredWords'++-- | evaluate a query into a ScoredWords result+--+-- all info about contexts, words and positions is removed by the aggregation,+-- just a set of words and associated scores is computed.+--+-- the words found are suggestions for the last primitive prefix in the query++evalScoredWords :: Query -> Processor ScoredWords+evalScoredWords q+    | isPrimaryQuery q+        = do res <- forallCx (evalPrimary q)+             aggregateToScoredResult res++evalScoredWords (QRange lb ub)+    = do res <- forallCx (evalRange lb ub)+         aggregateToScoredResult res++evalScoredWords (QSeq Or qs)                           -- for completions just search+    = evalScoredWords' (last qs)                       -- for rightmost subquery++evalScoredWords (QSeq AndNot qs)                       -- for completions just search+    = evalScoredWords' (last qs)                       -- for rightmost subquery++evalScoredWords (QSeq And qs)                          -- for completions+    = do docs <- evalUnScoredDocs  (mkQ $ init qs)     -- eval the set of docs for all but the last q+         res  <- evalScoredRawDocs (      last qs)     -- eval the last q as ScoredRawDos+         aggregateToScoredResult                       -- aggregate to ScoredWords+           $ fmap (filterByDocSet docs) res            -- restrict result to docs found+      where+        mkQ [q'] = q'+        mkQ qs'  = QSeq And qs'++evalScoredWords (QSeq op qs)+    | isLocalCxOp op+        = do res <- forallCxLocal+                    ( evalSeq' op                      -- do the position aware operation+                      <$> mapM evalScoredRawDocs' qs ) -- switch to the raw evaluator due to positions+             aggregateToScoredResult res               -- and aggregate res to ScoredWords++evalScoredWords (QContext cxs q)+    = withCxs cxs $ evalScoredWords' q++evalScoredWords (QBoost w q)+    = boost w <$> evalScoredWords' q++evalScoredWords q@QPhrase{}              -- QPhrase is transformed into QFullWord or QSeq Phrase+    = normPhraseQuery q >>= evalScoredWords++evalScoredWords q@QBinary{}              -- QBin is transformed into QSeq+    = normQuery q >>= evalScoredWords++evalScoredWords q+    = queryEvalError q++-- --------------------+-- {- switch off trace++evalScoredWords' :: Query -> Processor ScoredWords+evalScoredWords' = evalScoredWords+{-# INLINE evalScoredWords' #-}++-- -}+{- switch on trace of evaluation++evalScoredWords' :: Query -> Processor ScoredWords+evalScoredWords' q = trc <$> evalScoredWords q+    where+      trc res = traceShow ("evalScoredWords: "::String,q  ) $+                traceShow ("evalScoredWords: "::String,res) $ res+-- -}+-- ------------------------------------------------------------++-- | evaluate a query into a context aware raw docs result+--+-- This evaluator is called from 'evalScoredDocs', 'evalUnScoredDocs' and 'evalScoredWords'+-- in the case of Phrase-, Follow- and Near-queries.+--+-- No info about contexts, words and positions is removed by the aggregation.+-- 'evalScoredRawDocs' always runs in a single context at a time,+-- because the position information does not have any meaning across contexts+--+-- Therefore QContext subqueries become meaningless within Phrase-, Follow- and Near-queries++evalScoredRawDocs :: Query -> Processor (ScoredCx ScoredRawDocs)+evalScoredRawDocs q+    | isPrimaryQuery q+        = forallCx (evalPrimary q)++evalScoredRawDocs (QRange lb ub)+    = forallCx (evalRange lb ub)++evalScoredRawDocs (QSeq op qs)+    = evalSeq' op+      <$> mapM evalScoredRawDocs' qs++evalScoredRawDocs (QContext cxs q)+    = restrictCxs cxs $ evalScoredRawDocs' q++evalScoredRawDocs (QBoost w q)+    = boost w <$> evalScoredRawDocs' q++evalScoredRawDocs q@QPhrase{}              -- QPhrase is transformed into QFullWord or QSeq Phrase+    = normQuery q >>= evalScoredRawDocs++evalScoredRawDocs q@QBinary{}              -- QBin is transformed into QSeq+    = normQuery q >>= evalScoredRawDocs++evalScoredRawDocs q+    = queryEvalError q++-- --------------------+-- {- switch off trace++evalScoredRawDocs' :: Query -> Processor (ScoredCx ScoredRawDocs)+evalScoredRawDocs' = evalScoredRawDocs+{-# INLINE evalScoredRawDocs' #-}++-- -}+{- switch on trace of evaluation++evalScoredRawDocs' :: Query -> Processor (ScoredCx ScoredRawDocs)+evalScoredRawDocs' q = trc <$> evalScoredRawDocs q+    where+      trc res = traceShow ("evalScoredRawDocs: "::String,q  ) $+                traceShow ("evalScoredRawDocs: "::String,res) $ res+-- -}+-- ------------------------------------------------------------++-- run a query evaluation++processQueryScoredResult :: (q -> Processor r) -> ProcessEnv -> q -> IO (Either CmdError r)+processQueryScoredResult eval st q+    = runErrorT . runReaderT (runProcessor $ eval q) $ st+++-- ------------------------------------------------------------+--+-- query normalization: transform "old" queries into generalized new form++normQuery :: Query -> Processor Query+normQuery (QPhrase op w)+    = return . QSeq Phrase . L.map (QFullWord op) $ T.words w++normQuery q@(QBinary op _q1 _q2)+    = return . QSeq op . collect op q $ []+      where+        collect+            | isAssocOp     op = collectAssoc+            | isLeftAssocOp op = collectLeftAssoc+            | otherwise        = \ _op q' -> (q':)++normQuery q+    = return q+++normPhraseQuery :: Query -> Processor Query+normPhraseQuery (QPhrase op w)+    = return . QSeq Phrase $ normPhrase (T.words w) []+    where+      normPhrase (x:[]) r = r ++ [QWord op x]+      normPhrase (x:xs) r = normPhrase xs $+                            r ++ [QFullWord op x]+      normPhrase []     r = r+normPhraseQuery q+    = return q++++collectAssoc :: BinOp -> Query -> [Query] -> [Query]+collectAssoc op (QBinary op' q1 q2)+    | op == op'+        = collectAssoc op q1 . collectAssoc op q2+collectAssoc _ q+    = (q :)++collectLeftAssoc :: BinOp -> Query -> [Query] -> [Query]+collectLeftAssoc op (QBinary op' q1 q2)+    | op == op'+        = collectAssoc op q1 . (q2 :)+collectLeftAssoc _ q+    = (q :)++isAssocOp :: BinOp -> Bool+isAssocOp AndNot = False+isAssocOp _      = True++isLeftAssocOp :: BinOp -> Bool          -- currently AndNot is left assoc+isLeftAssocOp = not . isAssocOp         -- all others are assoc ops++isLocalCxOp :: BinOp -> Bool+isLocalCxOp Phrase   = True+isLocalCxOp Follow{} = True+isLocalCxOp Near{}   = True+isLocalCxOp _        = False++-- ------------------------------------------------------------++-- eval query combinators++evalSeq :: (ScoredResult r) => BinOp -> [r] -> r+evalSeq Or     = evalOr+evalSeq And    = evalAnd+evalSeq AndNot = evalAndNot+evalSeq _op    = const mempty++evalSeq' :: BinOp -> [ScoredCx ScoredRawDocs] -> ScoredCx ScoredRawDocs+evalSeq' Phrase     = evalSequence id+evalSeq' (Follow d) = evalFollow   id d+evalSeq' (Near   d) = evalNear     id d+evalSeq' op         = evalSeq op++-- | restrict the current context for a query+--+-- used in evaluating phrase-, follow- and near- queries+-- there it's meaningless to use other than the current contexts++restrictCxs :: [Context] -> Processor r -> Processor r+restrictCxs cxs p+    = do cxs0 <- getContexts+         withCxs cxs $                                           -- check for legal contexts+                 local (setCx $ cxs0 `L.intersect` L.nub cxs) p  -- restrict contexts to cxs+    where+      setCx cxs' cfg+          = cfg {psContexts = cxs'}++-- | set the context for a part of a query evaluation++withCxs :: [Context] -> Processor r -> Processor r+withCxs cxs p+    = do icxs <- invalidContexts <$> getSchema+         if L.null icxs+            then local setCx $ p+            else queryError 404+                 $ "mentioned context(s) do not exist: "+                   <> showText icxs+    where+      invalidContexts sc+          = filter (\ c -> not (c `M.member` sc)) cxs+      setCx cfg+          = cfg {psContexts = L.nub cxs}++-- | execute a command (query) for all contexts and give the current context+-- as extra argument++forallCx :: (ScoredResult r) => (Context -> Processor r) -> Processor r+forallCx action+    = do cxs <- getContexts+         res <- mapM action cxs+         return $ mconcat res++-- | execute a command for all contexts, but restrict the set of contexts+-- to the current context before executing the command+--+-- So the loop over all contexts (forallCx) called in the evaluation of primary+-- queries is switched off++forallCxLocal :: (ScoredResult r) => Processor r -> Processor r+forallCxLocal action+    = do cxs <- getContexts+         res <- mapM f' cxs+         return $ mconcat res+    where+      f' cx+          = withCxs [cx] action++isPrimaryQuery :: Query -> Bool+isPrimaryQuery QWord{}     = True+isPrimaryQuery QFullWord{} = True+isPrimaryQuery _           = False++queryEvalError :: Query -> Processor r+queryEvalError q+    = queryError 501 $ "Hunt.Query.Processor: query can't be evaluated " <> showText q++-- ------------------------------------------------------------++aggregateToScoredResult :: (Aggregate a (ScoredCx b), ScoredResult b) =>+                           a -> ProcessorT IO b+aggregateToScoredResult res+    = do cxScores <- contextWeights <$> getSchema+         return $ boostAndAggregateCx cxScores (aggregate res)+++-- eval basic queries++evalPrimary :: Query -> Context -> Processor (ScoredCx ScoredRawDocs)+evalPrimary (QWord QCase w) cx+    = searchCx PrefixCase w cx++evalPrimary (QWord QNoCase w) cx+    = searchCx PrefixNoCase w cx++evalPrimary (QWord QFuzzy w) cx         -- TODO: QFuzzy is processed like nocase search+    = searchCx PrefixNoCase w cx++evalPrimary (QFullWord QCase w) cx+    = searchCx Case w cx++evalPrimary (QFullWord QNoCase w) cx+    = searchCx NoCase w cx++evalPrimary (QFullWord QFuzzy w) cx     -- TODO: QFuzzy is processed like nocase search+    = searchCx NoCase w cx++evalPrimary q _cx+    = queryError 501 $ "evalPrimary: not a primary query: " <> showText q++searchCx :: TextSearchOp -> Word -> Context -> Processor (ScoredCx ScoredRawDocs)+searchCx op w' cx+    = do mw <- normQueryCx cx w'                         -- normalize the word with respect to context+         case mw of+           Nothing  -> return $ fromCxRawResults []      -- if normalization not possible, return empty result+           (Just w) -> searchCx' w+    where+      searchCx' w+        = do+          limit <- asks (docLimit . psConfig)            -- get the max. # of docs+          ix    <- getIx                                 -- get the context search index+          rawr  <- limitRawResult limit+                   <$> CIx.searchWithCxSc op cx w ix     -- do the real search and limit result+          return $ fromCxRawResults [(cx, rawr)]+                                                         -- convert the result to a ScoredResult+                                                         -- the score comes from a similarity test++evalRange :: Word -> Word -> Context -> Processor (ScoredCx ScoredRawDocs)+evalRange lb0 ub0 cx+    = do mlb    <- normQueryCx cx lb0                         -- normalize the word with respect to context+         mub    <- normQueryCx cx ub0                         -- normalize the word with respect to context+         case (mlb, mub) of+           (Just lb, Just ub) -> evalRange' lb ub+           _                  -> return $ fromCxRawResults [] -- if one of the words fails validation, return empty result+    where+      evalRange' lb ub+        = do+          limit <- asks (docLimit . psConfig)+          ix    <- getIx+          rawr  <- limitRawResult limit+                   <$> CIx.lookupRangeCxSc cx lb ub ix+          return $ fromCxRawResults [(cx, rawr)]++-- ------------------------------------------------------------++{-+-- | Log a message at 'WARNING' priority.+warningM :: String -> IO ()+warningM = Log.warningM modName++-- | Log a message at 'ERROR' priority.+errorM :: String -> IO ()+errorM = Log.errorM modName+-}++-- ------------------------------------------------------------
+ src/Hunt/Query/Ranking.hs view
@@ -0,0 +1,231 @@+-- ----------------------------------------------------------------------------+{- |+  Module     : Hunt.Query.Ranking+  Copyright  : Copyright (C) 2007, 2008 Timo B. Huebel+  License    : MIT++  Maintainer : Timo B. Huebel (tbh@holumbus.org)+  Stability  : experimental+  Portability: portable+  Version    : 0.3++  The ranking mechanism for Hunt.++  Customized ranking functions for both documents and suggested words can be+  provided by the user. Some predefined ranking functions are avaliable, too.++-}+-- ----------------------------------------------------------------------------++module Hunt.Query.Ranking+  (+  -- * Ranking types+    RankConfig (..)+  , DocRanking+  , WordRanking+  , ContextWeights++  -- * Ranking+  , rank++  -- * Predefined document rankings+  , docRankByCount+  --, docRankWeightedByCount++  -- * Predefined word rankings+  , wordRankByCount+  , wordRankBySimilarity+  --, wordRankWeightedByCount++  , defaultRankConfig+  )+where++import           Prelude               hiding (foldr)++import           Control.Applicative++--import           Data.Foldable+--import           Data.Function+import           Data.Maybe++import qualified Data.List             as L+import           Data.Map              (Map)+import qualified Data.Map              as M+import           Data.Text             (Text)+import qualified Data.Text             as T++import           Hunt.Common+import qualified Hunt.Common.DocIdMap  as DM+import           Hunt.Common.Document  (DocumentWrapper (..))+import           Hunt.Common.Positions as Pos+import           Hunt.DocTable         as Dt+import           Hunt.Query.Result++import           Hunt.Utility++-- import           Debug.Trace++-- ------------------------------------------------------------++-- | The configuration of the ranking mechanism.+data RankConfig e+  = RankConfig+    { docRanking  :: DocRanking e   -- ^ A function to determine the score of a document.+    , wordRanking :: WordRanking    -- ^ A function to determine the score of a word.+    }++-- | The signature of a function to determine the score of a document.+type DocRanking e = ContextWeights -> DocId -> Score -> DocInfo e -> DocContextHits -> Score++-- TODO: add ContextWeights+-- | The signature of a function to determine the score of a word.+type WordRanking  = Word -> WordInfo -> WordContextHits -> Score++-- | Weights for the contexts (optional).+type ContextWeights = Map Context Weight++-- ------------------------------------------------------------++-- | The configuration of the ranking mechanism.+defaultRankConfig :: DocumentWrapper e => RankConfig e+defaultRankConfig+    = RankConfig+      { docRanking  = docRankByCount+      , wordRanking = wordRankBySimilarity+      -- , wordRanking = wordRankByCount+      }++-- ------------------------------------------------------------++-- | Rank the result with custom ranking functions (and the given context weights).++rank :: (DocTable dt, Monad m, Applicative m) =>+        RankConfig e -> dt -> ContextWeights -> Result e -> m (Result e)++rank (RankConfig fd fw {-ld lw-}) dt cw r+  = do sdh <- scoredDocHits+       return $ Result sdh scoredWordHits+  where+    scoredDocHits+        = DM.traverseWithKey+          (\k (di, dch) ->+               do+                 kw <- maybe defScore (wght . unwrap) <$> Dt.lookup k dt+                 return $ ( setDocScore (fd cw k kw di dch) di+                          , dch+                          )+          ) $ docHits r++    scoredWordHits+        = M.mapWithKey+          ( \ k (WIH wi wch) -> WIH (setWordScore (fw k wi wch) wi) wch )+          $ wordHits r++-- ------------------------------------------------------------++-- | Rank documents by count and multiply occurrences with+--   their respective context weights (default @1.0@).+--   Pass an empty map to discard context weights.+--+-- @docRankByCount :: ContextWeights -> DocId -> Score -> DocInfo e -> DocContextHits -> Score@++docRankByCount :: DocRanking e+docRankByCount cw _ docWeight di h+    = docBoost di * docWeight * scHits+    where+      scHits = M.foldrWithKey+               (\cx -> (cxw cx *)+                       .::+                       flip (M.foldr (\h2 r2 -> mkScore (fromIntegral (Pos.size h2)) + r2))+               ) noScore h++      cxw cx = fromMaybe defScore $ M.lookup cx cw++-- | Rank words by count.+--+-- @wordRankByCount :: Word -> WordInfo -> WordContextHits -> Score@+wordRankByCount :: WordRanking+wordRankByCount _w _i h+  = countHits h++wordRankBySimilarity :: WordRanking+wordRankBySimilarity wordFound (WordInfo searchTerms sc) wch+    = cnt * toDefScore sc * simBoost+    where+      cnt = countHits wch++      simBoost :: Score+      simBoost+          | L.null searchTerms            -- make simBoost total+              = noScore+          | otherwise+              = maximum (L.map (similar wordFound) searchTerms)++      similar :: Text -> Text -> Score+      similar found searched+          | searched == found+              = boostExactHit+          | ls == lf+              = boostSameLength+          | ls < lf                     -- reduce score by length of found word+              = fromIntegral ls / fromIntegral lf+          | otherwise                   -- make similar total+              = noScore+          where+            boostExactHit   = 10.0+            boostSameLength =  5.0      -- NoCase hits++            ls = T.length searched+            lf = T.length found++countHits :: WordContextHits -> Score+countHits wch+    = M.foldr op 0.0 wch+    where+      op x res = DM.foldr (+) 0.0 x + res++-- ------------------------------------------------------------++-- The old weighting mechanism+--   - used a list of context weights+--   - normalizes the weights to a maximum of 1.0+--     - not sure if this is really necessary or the users responsibility+--     - the computation should be done /once/ every time the weights are set, not with every query+--   - seems overall cumbersome++{-+-- | Rank documents by context-weighted count. The weights will be normalized to a maximum of 1.0.+--   Contexts with no weight (or a weight of zero) will be ignored.+docRankWeightedByCount :: [(Context, Score)] -> DocId -> DocInfo e -> DocContextHits -> Score+docRankWeightedByCount ws _ _+  =  M.foldrWithKey (calcWeightedScore ws) 0.0++-- | Rank words by context-weighted count. The weights will be normalized to a maximum of 1.0.+--   Contexts with no weight (or a weight of zero) will be ignored.+wordRankWeightedByCount :: [(Context, Score)] -> Word -> WordInfo -> WordContextHits -> Score+wordRankWeightedByCount ws _ _+  = M.foldrWithKey (calcWeightedScore ws) 0.0++-- | Calculate the weighted score of occurrences of a word.+calcWeightedScore :: Foldable f => [(Context, Score)] -> Context -> f Positions -> Score -> Score+calcWeightedScore ws c h r+  = maybe r (\w -> r + ((w / mw) * count)) $ lookupWeight c ws+  where+  count = fromIntegral $ foldl' (flip $ (+) . Pos.size) 0 h+  mw    = snd $ L.maximumBy (compare `on` snd) ws++-- | Find the weight of a context in a list of weights. If the context was not found or it's+--   weight is equal to zero, 'Nothing' will be returned.+lookupWeight :: Context -> [(Context, Score)] -> Maybe Score+lookupWeight _ []     = Nothing+lookupWeight c (x:xs)+  = if fst x == c+    then+      if snd x /= 0.0+      then Just (snd x)+      else Nothing+    else lookupWeight c xs+-}++-- ------------------------------------------------------------
+ src/Hunt/Query/Result.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE StandaloneDeriving #-}++-- ----------------------------------------------------------------------------+{- |+  Module     : Hunt.Query.Result+  Copyright  : Copyright (C) 2007 Timo B. Huebel+  License    : MIT++  Maintainer : Timo B. Huebel (tbh@holumbus.org)+  Stability  : experimental+  Portability: portable++  The data type for results of Holumbus queries.++  The result of a query is defined in terms of two partial results,+  the documents containing the search terms and the words which+  are possible completions of the search terms.+-}+-- ----------------------------------------------------------------------------++module Hunt.Query.Result+  (+  -- * Result data types+    Result(..)+  , DocHits+  , DocContextHits+  , DocWordHits+  , WordHits+  , WordContextHits+  , WordDocHits+  , DocInfo(..)+  , WordInfo(..)+  , WordInfoAndHits(..)+  , Score+  , Weight+  , Boost+  , DocBoosts++  -- * Construction+  , emptyResult++  -- * Query+  , null+  , sizeDocHits+  , sizeWordHits+  , maxScoreDocHits+  , maxScoreWordHits+  , getDocuments++  -- * Transform+  , setDocScore+  , setWordScore+  )+where++import           Prelude              hiding (null)++import qualified Data.List            as L+import           Data.Map             (Map)+import qualified Data.Map             as M+import           Data.Text            (Text)++import           Hunt.Common+import qualified Hunt.Common.DocIdMap as DM++-- ------------------------------------------------------------++-- | The combined result type for Holumbus queries.+data Result e+  = Result+    { docHits  :: DocHits e  -- ^ The documents matching the query.+    , wordHits :: WordHits   -- ^ The words which are completions of the query terms.+    }+deriving instance Show e => Show (Result e)+++-- | Information about an document.+data DocInfo e+    = DocInfo+      { document :: e      -- ^ The document itself.+      , docBoost :: Weight -- ^ The document weight, init with @1.0@+      , docScore :: Score  -- ^ The score for the document (initial score for all documents is @0.0@).+      }++instance Show (DocInfo e) where+    show (DocInfo _d b s) = "DocInfo d " ++ show b ++ " " ++ show s++-- | Information about a word.+data WordInfo+    = WordInfo+      { terms     :: Terms -- ^ The search terms that led to this very word.+      , wordScore :: Score -- ^ The frequency of the word in the document for a context.+      }+    deriving (Eq, Show)++instance Monoid WordInfo where+    mempty+        = WordInfo [] noScore+    mappend (WordInfo t1 s1) (WordInfo t2 s2)+        = WordInfo (t1 `L.union` t2) (s1 <> s2)++data WordInfoAndHits+    = WIH WordInfo WordContextHits+      deriving (Eq, Show)++instance Monoid WordInfoAndHits where+    mempty+        = WIH mempty M.empty+    mappend (WIH wi1 wh1) (WIH wi2 wh2)+        = WIH (wi1 <> wi2) (M.unionWith (DM.unionWith (+)) wh1 wh2)++-- XXX: a list for now - maybe useful for testing+-- | Boosting of a single document.+type Boost           = Score++-- | Document boosting.+type DocBoosts       = DocIdMap Score++-- | A mapping from a document to it's score and the contexts where it was found.+type DocHits e       = DocIdMap (DocInfo e, DocContextHits)++-- | A mapping from a context to the words of the document that were found in this context.+type DocContextHits  = Map Context DocWordHits++-- | A mapping from a word of the document in a specific context to it's positions.+type DocWordHits     = Map Word Positions++-- | A mapping from a word to it's score and the contexts where it was found.+type WordHits        = Map Word WordInfoAndHits++-- | A mapping from a context to the documents that contain the word that were found in this context.+type WordContextHits = Map Context WordDocHits++-- | A mapping from a document containing the word to the positions of the word.+type WordDocHits     = DocBoosts++-- | The original search terms entered by the user.+type Terms           = [Text]++-- ------------------------------------------------------------++-- | Create an empty result.+emptyResult :: Result e+emptyResult = Result DM.empty M.empty++-- | Query the number of documents in a result.+sizeDocHits :: Result e -> Int+sizeDocHits = DM.size . docHits++-- | Query the number of documents in a result.+sizeWordHits :: Result e -> Int+sizeWordHits = M.size . wordHits++-- | Query the maximum score of the documents.+maxScoreDocHits :: Result e -> Score+maxScoreDocHits = DM.foldr (\(di, _) r -> max (docScore di) r) 0.0 . docHits++-- | Query the maximum score of the words.+maxScoreWordHits :: Result e -> Score+maxScoreWordHits = M.foldr (\ (WIH wi _) r -> max (wordScore wi) r) 0.0 . wordHits++-- | Test if the result contains anything.+null :: Result e -> Bool+null = DM.null . docHits++-- | Set the score in a document info.+setDocScore :: Score -> DocInfo e -> DocInfo e+setDocScore s di = di { docScore = s }++-- | Set the score in a word info.+setWordScore :: Score -> WordInfo -> WordInfo+setWordScore s wi = wi { wordScore = s }++-- | Extract all documents from a result.+getDocuments :: Result e -> [e]+getDocuments r = map (document . fst . snd) . DM.toList $ docHits r++-- ------------------------------------------------------------
+ src/Hunt/Utility.hs view
@@ -0,0 +1,234 @@+{-# LANGUAGE BangPatterns   #-}+{-# LANGUAGE EmptyDataDecls #-}++-- ----------------------------------------------------------------------------+{- |+  General utitlity functions.+-}+-- ----------------------------------------------------------------------------++module Hunt.Utility+  (+    -- * Function Composition+    (.::), (.:::)++    -- * Safe / Total Functions+  , head'++    -- * Strict Functions+  , foldM'++    -- * Monadic Functions+  , foldlWithKeyM, foldrWithKeyM+  , whenM++    -- * Maybe Helper+  , catMaybesSet++    -- * Either Helper+  , isLeft, isRight+  , fromLeft, fromRight++    -- * List Helper+  , unbox, unboxM, isSingleton+  , split+  , partitionListByLength, partitionListByCount+  , descending++    -- * String Helper+  , strip, stripl, stripr, stripWith+  , escape++    -- * Text Helper+  , showText++    -- * Aeson Helper+  , object', (.=?), (.==), (.\.)++  -- * Types+  , TypeDummy+  )+where++import           Control.Monad    (when)++import           Data.Aeson       hiding (decode)+import           Data.Aeson.Types+import           Data.Char+import qualified Data.Foldable    as FB+import qualified Data.List        as L+import           Data.Map         (Map)+import qualified Data.Map         as M+import           Data.Maybe       (fromJust)+import           Data.Set         (Set)+import qualified Data.Set         as S+import           Data.Text        (Text)+import qualified Data.Text        as T++import           Numeric          (showHex)++-- ------------------------------------------------------------++-- | A dummy type without constructor.+data TypeDummy++-- ------------------------------------------------------------++showText :: Show a => a -> Text+showText = T.pack . show++-- | The boob operator.+(.::) :: (c -> d) -> (a -> b -> c) -> a -> b -> d+(.::) = (.).(.)++-- | The Total Recall operator.+(.:::) :: (d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e+(.:::) = (.).(.).(.)++-- | Safe 'head'.+head' :: [a] -> Maybe a+head' xs = if null xs then Nothing else Just $ head xs++-- | 'Data.Maybe.catMaybes' on a 'Set' instead of a List.+catMaybesSet :: Ord a => Set (Maybe a) -> [a]+catMaybesSet = S.toList . S.map fromJust . S.delete Nothing++-- | Test if 'Either' is a 'Left' value.+isLeft :: Either a b -> Bool+isLeft = either (const True) (const False)++-- | Test if 'Either' is a 'Right' value.+isRight :: Either a b -> Bool+isRight = not . isLeft++-- | Unwraps a 'Left' value - fails on 'Right'.+fromLeft :: Either a b -> a+fromLeft = either id (error "Hunt.Utility.fromLeft: Right")++-- | Unwraps a 'Right' value - fails on 'Left'.+fromRight :: Either a b -> b+fromRight = either (error "Hunt.Utility.fromRight: Left") id++-- | Unbox a singleton.+--+--   /Note/: This fails if the list is not a singleton.+unbox :: [a] -> a+unbox [e] = e+unbox _   = error "unbox: []"++-- | Unbox a singleton in a safe way with 'Maybe'.+unboxM :: [a] -> Maybe a+unboxM [e] = Just e+unboxM _   = Nothing++-- | Test if the list contains a single element.+isSingleton :: [a] -> Bool+isSingleton [_] = True+isSingleton _   = False++-- | Split a string into seperate strings at a specific character sequence.+split :: Eq a => [a] -> [a] -> [[a]]+split _ []       = [[]]+split at w@(x:xs) = maybe ((x:r):rs) ((:) [] . split at) (L.stripPrefix at w)+                    where (r:rs) = split at xs++-- | Removes leading and trailing whitespace from a string.+strip :: String -> String+strip = stripWith isSpace++-- | Removes leading whitespace from a string.+stripl :: String -> String+stripl = dropWhile isSpace++-- | Removes trailing whitespace from a string.+stripr :: String -> String+stripr = reverse . dropWhile isSpace . reverse++-- | Strip leading and trailing elements matching a predicate.+stripWith :: (a -> Bool) -> [a] -> [a]+stripWith f = reverse . dropWhile f . reverse . dropWhile f++-- | partition the list of input data into a list of input data lists of+--   approximately the same specified length+partitionListByLength :: Int -> [a] -> [[a]]+partitionListByLength _ [] = []+partitionListByLength count l  = take count l : partitionListByLength count (drop count l)++-- | partition the list of input data into a list of a specified number of input data lists with+--   approximately the same length+partitionListByCount :: Int -> [a] -> [[a]]+partitionListByCount = partition+  where+  partition 0 _ = []+  partition sublists l+    = let next = (length l `div` sublists)+      in  if next == 0  then [l]+                        else take next l : partition (sublists -1) (drop next l)++-- | To use with 'sortBy'.+descending :: Ord a => a -> a -> Ordering+descending = flip compare++-- | Escapes non-alphanumeric or space characters in a String+escape :: String -> String+escape []     = []+escape (c:cs)+  = if isAlphaNum c || isSpace c+      then c : escape cs+      else '%' : showHex (fromEnum c) "" ++ escape cs++-- | Strict version of 'foldM'.+foldM' :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a+foldM' _ acc [] = return acc+foldM' f acc (x:xs) = do+  !acc' <- f acc x+  foldM' f acc' xs++-- | 'FB.foldrM' for 'Map' with key.+foldrWithKeyM :: (Monad m) => (k -> a -> b -> m b) -> b -> Map k a -> m b+foldrWithKeyM f b = FB.foldrM (uncurry f) b . M.toList++-- | 'FB.foldlM' for 'Map' with key.+foldlWithKeyM :: (Monad m) => (b -> k -> a -> m b) -> b -> Map k a -> m b+foldlWithKeyM f b = FB.foldlM f' b . M.toList+  where f' a = uncurry (f a)++-- | Monadic 'when'.+whenM :: Monad m => m Bool -> m () -> m ()+whenM bm f = bm >>= \b -> when b f++-- ------------------------------------------------------------+-- Aeson helper+-- ------------------------------------------------------------++-- | Like 'Data.Aeson.object' to use with '.=?', '.==' and '.\.'.+--   This allows omitting (default) values in 'ToJSON' instances.+--+-- > toJSON (Example maybe list float) = object' $+-- >   [ "maybe" .=? maybe .\. isNothing+-- >   , "list"  .=? list  .\. null+-- >   , "float" .=? float .\. (== 1.0)+-- >   ]+object' :: [[Pair]] -> Value+object' = object . Prelude.concat++-- | Like '.=' but allows omitting of (default) values in 'ToJSON' instances.+--+--   See 'object''.+(.=?) :: ToJSON a => Text -> (a, a -> Bool) -> [Pair]+name .=? (value, cond) = if cond value then [] else [ name .= value ]++-- | '.==' for 'object''.+--+--   See 'object''.+(.==) :: ToJSON a => Text -> a -> [Pair]+name .== value = [ name .= value ]++-- | Use with '.=?' to specify which value to omit.+--+--   See 'object''.+(.\.) :: ToJSON a => a -> (a -> Bool) -> (a, a -> Bool)+v .\. c = (v,c)+infixl 8 .=?++-- ------------------------------------------------------------
+ src/Hunt/Utility/Log.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances #-}++-- ----------------------------------------------------------------------------+{- |+  Logging auxiliary functions.++  The 'LogShow' is an alternative 'Show' instance for a custom representation in logs.+  It uses the 'Show' instance by default.+-}+-- ----------------------------------------------------------------------------++module Hunt.Utility.Log where++-- | Alternative 'Show' instance for a custom representation in logs.+--   It uses the 'Show' instance by default.+class LogShow e where+  logShow :: e -> String++instance Show e => LogShow e where+  logShow = show
+ src/Hunt/Utility/Output.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}++-- ------------------------------------------------------------++module Hunt.Utility.Output+where+import           Control.Monad.IO.Class++import           Data.Aeson+import           Data.Aeson.Encode.Pretty+import qualified Data.ByteString.Lazy       as LB+import           Data.Monoid+import           Data.Text                  ()++import           System.FilePath            ()++-- ------------------------------------------------------------++--+outputValue :: (Functor m, MonadIO m, ToJSON c) => String -> c -> m ()+outputValue fn c+    = liftIO (jsonOutput True toFile c)+    where+      toFile bs+          | fn == ""+            ||+            fn == "-"+                = LB.putStr bs+          | otherwise+              = LB.writeFile fn bs++-- TODO: merge with Hunt.Server.Client.handleJsonResponse+--evalOkRes :: MonadIO m => Maybe LB.ByteString -> m ()+--evalOkRes Nothing+--    = return ()+--evalOkRes (Just bs)+--    | isOkMsg bs = return ()+--    | otherwise  = liftIO . ioError . userError $+--                  "server error: \"ok\" expected, but got " ++ show (LC.unpack bs)+--    where+--      isOkMsg s = maybe False ((== "ok") . unCmdRes) js+--          where+--            js :: Maybe (CmdRes Text)+--            js = decode s++--evalErrRes :: MonadIO m => Int -> LB.ByteString -> m a+--evalErrRes rc bs+--    = liftIO . ioError . userError $+--      unwords ["server error: rc=", show rc, "msg=", msg ce]+--    where+--      ce :: Maybe CmdError+--      ce = decode bs++--      msg Nothing  = "result is not a JSON error message"+--      msg (Just e) = show e++-- ------------------------------------------------------------++jsonOutput :: (ToJSON c) => Bool -> (LB.ByteString -> IO a) -> c -> IO a+jsonOutput pretty io x+    = io $ (if pretty then encodePretty' encConfig else encode) x+      where+        encConfig :: Config+        encConfig+            = Config { confIndent = 2+                     , confCompare+                         = keyOrder ["description", "index", "uri"]+                           `mappend`+                           compare+                     }
+ test/Hunt.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeSynonymInstances      #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE ExistentialQuantification #-}++module Main where++import           Hunt.AnalyzerTests+import           Hunt.IndexTests+import           Hunt.InterpreterTests+import           Hunt.QueryParserTests+--import           Hunt.RankingTests++import           Test.Framework++main :: IO ()+main = defaultMain+       $ analyzerTests+       ++ contextTypeTests+       ++ interpreterTests+       ++ queryParserTests+--     XXX refactor ranking tests to be conform with new ranking+--       ++ rankingTests
+ test/Strictness.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeSynonymInstances      #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE ExistentialQuantification #-}++module Main where++import           Hunt.Strict.DocTable+import           Hunt.Strict.Index+import           Hunt.Strict.ContextIndex++import           Test.Framework++main :: IO ()+main = defaultMain $ docTableTests ++ indexTests ++ contextIndexTests+