@@ -6,6 +6,7 @@ module Database.V5.Bloodhound.Internal.Analysis where
66import Bloodhound.Import
77
88import qualified Data.Map.Strict as M
9+import Data.String
910import qualified Data.Text as T
1011
1112import Database.V5.Bloodhound.Internal.Newtypes
@@ -15,13 +16,15 @@ data Analysis = Analysis
1516 { analysisAnalyzer :: M.Map Text AnalyzerDefinition
1617 , analysisTokenizer :: M.Map Text TokenizerDefinition
1718 , analysisTokenFilter :: M.Map Text TokenFilterDefinition
19+ , analysisCharFilter :: M.Map Text CharFilterDefinition
1820 } deriving (Eq, Show)
1921
2022instance ToJSON Analysis where
21− toJSON (Analysis analyzer tokenizer tokenFilter) = object
23+ toJSON (Analysis analyzer tokenizer tokenFilter charFilter) = object
2224 [ "analyzer" .= analyzer
2325 , "tokenizer" .= tokenizer
2426 , "filter" .= tokenFilter
27+ , "char_filter" .= charFilter
2528 ]
2629
2730instance FromJSON Analysis where
@@ -29,6 +32,7 @@ instance FromJSON Analysis where
2932 <$> m .: "analyzer"
3033 <*> m .:? "tokenizer" .!= M.empty
3134 <*> m .:? "filter" .!= M.empty
35+ <*> m .:? "char_filter" .!= M.empty
3236
3337newtype Tokenizer =
3438 Tokenizer Text
@@ -37,18 +41,57 @@ newtype Tokenizer =
3741data AnalyzerDefinition = AnalyzerDefinition
3842 { analyzerDefinitionTokenizer :: Maybe Tokenizer
3943 , analyzerDefinitionFilter :: [TokenFilter]
44+ , analyzerDefinitionCharFilter :: [CharFilter]
4045 } deriving (Eq,Show)
4146
4247instance ToJSON AnalyzerDefinition where
43− toJSON (AnalyzerDefinition tokenizer tokenFilter) = object $ catMaybes
48+ toJSON (AnalyzerDefinition tokenizer tokenFilter charFilter) =
49+ object $ catMaybes
4450 [ fmap ("tokenizer" .=) tokenizer
4551 , Just $ "filter" .= tokenFilter
52+ , Just $ "char_filter" .= charFilter
4653 ]
4754
4855instance FromJSON AnalyzerDefinition where
4956 parseJSON = withObject "AnalyzerDefinition" $ \m -> AnalyzerDefinition
5057 <$> m .:? "tokenizer"
5158 <*> m .:? "filter" .!= []
59+ <*> m .:? "char_filter" .!= []
60+
61+-- | Character filters are used to preprocess the stream of characters
62+-- before it is passed to the tokenizer.
63+data CharFilterDefinition
64+ = CharFilterDefinitionMapping (M.Map Text Text)
65+ | CharFilterDefinitionPatternReplace
66+ { charFilterDefinitionPatternReplacePattern :: Text
67+ , charFilterDefinitionPatternReplaceReplacement :: Text
68+ , charFilterDefinitionPatternReplaceFlags :: Maybe Text
69+ }
70+ deriving (Eq, Show)
71+
72+instance ToJSON CharFilterDefinition where
73+ toJSON (CharFilterDefinitionMapping ms) = object
74+ [ "type" .= ("mapping" :: Text)
75+ , "mappings" .= [a <> " => " <> b | (a, b) <- M.toList ms] ]
76+ toJSON (CharFilterDefinitionPatternReplace pat repl flags) = object $
77+ [ "type" .= ("pattern_replace" :: Text)
78+ , "pattern" .= pat
79+ , "replacement" .= repl
80+ ] ++ maybe [] (\f -> ["flags" .= f]) flags
81+
82+instance FromJSON CharFilterDefinition where
83+ parseJSON = withObject "CharFilterDefinition" $ \m -> do
84+ t <- m .: "type"
85+ case (t :: Text) of
86+ "mapping" -> CharFilterDefinitionMapping . M.fromList <$> ms
87+ where
88+ ms = m .: "mappings" >>= mapM parseMapping
89+ parseMapping kv = case T.splitOn "=>" kv of
90+ (k:vs) -> pure (T.strip k, T.strip $ T.concat vs)
91+ _ -> fail "mapping is not of the format key => value"
92+ "pattern_replace" -> CharFilterDefinitionPatternReplace
93+ <$> m .: "pattern" <*> m .: "replacement" <*> m .:? "flags"
94+ _ -> fail ("unrecognized character filter type: " ++ T.unpack t)
5295
5396newtype TokenizerDefinition =
5497 TokenizerDefinitionNgram Ngram
@@ -112,6 +155,8 @@ data TokenFilterDefinition
112155 | TokenFilterDefinitionReverse
113156 | TokenFilterDefinitionSnowball Language
114157 | TokenFilterDefinitionShingle Shingle
158+ | TokenFilterDefinitionStemmer Language
159+ | TokenFilterDefinitionStop (Either Language [StopWord])
115160 deriving (Eq, Show)
116161
117162instance ToJSON TokenFilterDefinition where
@@ -143,6 +188,16 @@ instance ToJSON TokenFilterDefinition where
143188 , "token_separator" .= shingleTokenSeparator s
144189 , "filler_token" .= shingleFillerToken s
145190 ]
191+ TokenFilterDefinitionStemmer lang -> object
192+ [ "type" .= ("stemmer" :: Text)
193+ , "language" .= languageToText lang
194+ ]
195+ TokenFilterDefinitionStop stop -> object
196+ [ "type" .= ("stop" :: Text)
197+ , "stopwords" .= case stop of
198+ Left lang -> String $ "_" <> languageToText lang <> "_"
199+ Right stops -> toJSON stops
200+ ]
146201
147202instance FromJSON TokenFilterDefinition where
148203 parseJSON = withObject "TokenFilterDefinition" $ \m -> do
@@ -163,6 +218,19 @@ instance FromJSON TokenFilterDefinition where
163218 <*> (fmap.fmap) unStringlyTypedBool (m .:? "output_unigrams_if_no_shingles") .!= False
164219 <*> m .:? "token_separator" .!= " "
165220 <*> m .:? "filler_token" .!= "_"
221+ "stemmer" -> TokenFilterDefinitionStemmer
222+ <$> m .: "language"
223+ "stop" -> do
224+ stop <- m .: "stopwords"
225+ stop' <- case stop of
226+ String lang ->
227+ fmap Left
228+ . parseJSON
229+ . String
230+ . T.drop 1
231+ . T.dropEnd 1 $ lang
232+ _ -> Right <$> parseJSON stop
233+ return (TokenFilterDefinitionStop stop')
166234 _ -> fail ("unrecognized token filter type: " ++ T.unpack t)
167235
168236-- | The set of languages that can be passed to various analyzers,