{-# 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 }