mirror of
https://github.com/typeable/bloodhound.git
synced 2024-11-29 12:54:15 +03:00
Split out suggest, more cleanup
This commit is contained in:
Chris Allen
parent
5ce22d3a9f
commit
50d015dafa
@ -45,6 +45,7 @@ library
|
||||
Database.V5.Bloodhound.Internal.Query
|
||||
Database.V5.Bloodhound.Internal.Sort
|
||||
Database.V5.Bloodhound.Internal.StringlyTyped
|
||||
Database.V5.Bloodhound.Internal.Suggest
|
||||
Database.V1.Bloodhound
|
||||
Database.V1.Bloodhound.Client
|
||||
Database.V1.Bloodhound.Types
|
||||
|
||||
@ -6,10 +6,12 @@ module Database.V5.Bloodhound.Internal.Aggregation where
|
||||
|
||||
import Bloodhound.Import
|
||||
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Database.V5.Bloodhound.Internal.Client
|
||||
import Database.V5.Bloodhound.Internal.Highlight (HitHighlight)
|
||||
import Database.V5.Bloodhound.Internal.Newtypes
|
||||
import Database.V5.Bloodhound.Internal.Query
|
||||
import Database.V5.Bloodhound.Internal.Sort
|
||||
@ -304,3 +306,162 @@ data DateMathUnit =
|
||||
| DMMinute
|
||||
| DMSecond
|
||||
deriving (Eq, Show)
|
||||
|
||||
data TermsResult = TermsResult
|
||||
{ termKey :: BucketValue
|
||||
, termsDocCount :: Int
|
||||
, termsAggs :: Maybe AggregationResults
|
||||
} deriving (Read, Show)
|
||||
|
||||
instance FromJSON TermsResult where
|
||||
parseJSON (Object v) = TermsResult <$>
|
||||
v .: "key" <*>
|
||||
v .: "doc_count" <*>
|
||||
(pure $ getNamedSubAgg v ["key", "doc_count"])
|
||||
parseJSON _ = mempty
|
||||
|
||||
instance BucketAggregation TermsResult where
|
||||
key = termKey
|
||||
docCount = termsDocCount
|
||||
aggs = termsAggs
|
||||
|
||||
data DateHistogramResult = DateHistogramResult
|
||||
{ dateKey :: Int
|
||||
, dateKeyStr :: Maybe Text
|
||||
, dateDocCount :: Int
|
||||
, dateHistogramAggs :: Maybe AggregationResults
|
||||
} deriving (Show)
|
||||
|
||||
instance FromJSON DateHistogramResult where
|
||||
parseJSON (Object v) = DateHistogramResult <$>
|
||||
v .: "key" <*>
|
||||
v .:? "key_as_string" <*>
|
||||
v .: "doc_count" <*>
|
||||
(pure $ getNamedSubAgg v [ "key"
|
||||
, "doc_count"
|
||||
, "key_as_string"
|
||||
]
|
||||
)
|
||||
parseJSON _ = mempty
|
||||
|
||||
instance BucketAggregation DateHistogramResult where
|
||||
key = TextValue . showText . dateKey
|
||||
docCount = dateDocCount
|
||||
aggs = dateHistogramAggs
|
||||
|
||||
data DateRangeResult = DateRangeResult
|
||||
{ dateRangeKey :: Text
|
||||
, dateRangeFrom :: Maybe UTCTime
|
||||
, dateRangeFromAsString :: Maybe Text
|
||||
, dateRangeTo :: Maybe UTCTime
|
||||
, dateRangeToAsString :: Maybe Text
|
||||
, dateRangeDocCount :: Int
|
||||
, dateRangeAggs :: Maybe AggregationResults
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance FromJSON DateRangeResult where
|
||||
parseJSON = withObject "DateRangeResult" parse
|
||||
where parse v = DateRangeResult <$>
|
||||
v .: "key" <*>
|
||||
(fmap posixMS <$> v .:? "from") <*>
|
||||
v .:? "from_as_string" <*>
|
||||
(fmap posixMS <$> v .:? "to") <*>
|
||||
v .:? "to_as_string" <*>
|
||||
v .: "doc_count" <*>
|
||||
(pure $ getNamedSubAgg v [ "key"
|
||||
, "from"
|
||||
, "from_as_string"
|
||||
, "to"
|
||||
, "to_as_string"
|
||||
, "doc_count"
|
||||
]
|
||||
)
|
||||
|
||||
instance BucketAggregation DateRangeResult where
|
||||
key = TextValue . dateRangeKey
|
||||
docCount = dateRangeDocCount
|
||||
aggs = dateRangeAggs
|
||||
|
||||
toTerms :: Text -> AggregationResults -> Maybe (Bucket TermsResult)
|
||||
toTerms = toAggResult
|
||||
|
||||
toDateHistogram :: Text -> AggregationResults -> Maybe (Bucket DateHistogramResult)
|
||||
toDateHistogram = toAggResult
|
||||
|
||||
toMissing :: Text -> AggregationResults -> Maybe MissingResult
|
||||
toMissing = toAggResult
|
||||
|
||||
toTopHits :: (FromJSON a) => Text -> AggregationResults -> Maybe (TopHitResult a)
|
||||
toTopHits = toAggResult
|
||||
|
||||
toAggResult :: (FromJSON a) => Text -> AggregationResults -> Maybe a
|
||||
toAggResult t a = M.lookup t a >>= deserialize
|
||||
where deserialize = parseMaybe parseJSON
|
||||
|
||||
-- Try to get an AggregationResults when we don't know the
|
||||
-- field name. We filter out the known keys to try to minimize the noise.
|
||||
getNamedSubAgg :: Object -> [Text] -> Maybe AggregationResults
|
||||
getNamedSubAgg o knownKeys = maggRes
|
||||
where unknownKeys = HM.filterWithKey (\k _ -> k `notElem` knownKeys) o
|
||||
maggRes
|
||||
| HM.null unknownKeys = Nothing
|
||||
| otherwise = Just . M.fromList $ HM.toList unknownKeys
|
||||
|
||||
data MissingResult = MissingResult
|
||||
{ missingDocCount :: Int
|
||||
} deriving (Show)
|
||||
|
||||
instance FromJSON MissingResult where
|
||||
parseJSON = withObject "MissingResult" parse
|
||||
where parse v = MissingResult <$> v .: "doc_count"
|
||||
|
||||
data TopHitResult a = TopHitResult
|
||||
{ tarHits :: (SearchHits a)
|
||||
} deriving Show
|
||||
|
||||
instance (FromJSON a) => FromJSON (TopHitResult a) where
|
||||
parseJSON (Object v) = TopHitResult <$>
|
||||
v .: "hits"
|
||||
parseJSON _ = fail "Failure in FromJSON (TopHitResult a)"
|
||||
|
||||
data SearchHits a =
|
||||
SearchHits { hitsTotal :: Int
|
||||
, maxScore :: Score
|
||||
, hits :: [Hit a] } deriving (Eq, Show)
|
||||
|
||||
|
||||
instance (FromJSON a) => FromJSON (SearchHits a) where
|
||||
parseJSON (Object v) = SearchHits <$>
|
||||
v .: "total" <*>
|
||||
v .: "max_score" <*>
|
||||
v .: "hits"
|
||||
parseJSON _ = empty
|
||||
|
||||
instance Semigroup (SearchHits a) where
|
||||
(SearchHits ta ma ha) <> (SearchHits tb mb hb) =
|
||||
SearchHits (ta + tb) (max ma mb) (ha <> hb)
|
||||
|
||||
instance Monoid (SearchHits a) where
|
||||
mempty = SearchHits 0 Nothing mempty
|
||||
mappend = (<>)
|
||||
|
||||
|
||||
data Hit a =
|
||||
Hit { hitIndex :: IndexName
|
||||
, hitType :: MappingName
|
||||
, hitDocId :: DocId
|
||||
, hitScore :: Score
|
||||
, hitSource :: Maybe a
|
||||
, hitFields :: Maybe HitFields
|
||||
, hitHighlight :: Maybe HitHighlight } deriving (Eq, Show)
|
||||
|
||||
instance (FromJSON a) => FromJSON (Hit a) where
|
||||
parseJSON (Object v) = Hit <$>
|
||||
v .: "_index" <*>
|
||||
v .: "_type" <*>
|
||||
v .: "_id" <*>
|
||||
v .: "_score" <*>
|
||||
v .:? "_source" <*>
|
||||
v .:? "fields" <*>
|
||||
v .:? "highlight"
|
||||
parseJSON _ = empty
|
||||
|
||||
@ -5,8 +5,6 @@ module Database.V5.Bloodhound.Internal.Highlight where
|
||||
|
||||
import Bloodhound.Import
|
||||
|
||||
-- import Data.Aeson
|
||||
-- import Data.Aeson.Types (Parser)
|
||||
import qualified Data.Map.Strict as M
|
||||
|
||||
import Database.V5.Bloodhound.Internal.Newtypes
|
||||
@ -19,17 +17,32 @@ data Highlights = Highlights
|
||||
, highlightFields :: [FieldHighlight]
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance ToJSON Highlights where
|
||||
toJSON (Highlights global fields) =
|
||||
omitNulls (("fields" .= fields)
|
||||
: highlightSettingsPairs global)
|
||||
|
||||
data FieldHighlight =
|
||||
FieldHighlight FieldName (Maybe HighlightSettings)
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
instance ToJSON FieldHighlight where
|
||||
toJSON (FieldHighlight (FieldName fName) (Just fSettings)) =
|
||||
object [ fName .= fSettings ]
|
||||
toJSON (FieldHighlight (FieldName fName) Nothing) =
|
||||
object [ fName .= emptyObject ]
|
||||
|
||||
data HighlightSettings =
|
||||
Plain PlainHighlight
|
||||
| Postings PostingsHighlight
|
||||
| FastVector FastVectorHighlight
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
instance ToJSON HighlightSettings where
|
||||
toJSON hs = omitNulls (highlightSettingsPairs (Just hs))
|
||||
|
||||
data PlainHighlight =
|
||||
PlainHighlight { plainCommon :: Maybe CommonHighlight
|
||||
, plainNonPost :: Maybe NonPostings }
|
||||
@ -81,3 +94,71 @@ data HighlightTag =
|
||||
-- Only uses more than the first value in the lists if fvh
|
||||
| CustomTags ([Text], [Text])
|
||||
deriving (Eq, Show)
|
||||
|
||||
highlightSettingsPairs :: Maybe HighlightSettings -> [Pair]
|
||||
highlightSettingsPairs Nothing = []
|
||||
highlightSettingsPairs (Just (Plain plh)) = plainHighPairs (Just plh)
|
||||
highlightSettingsPairs (Just (Postings ph)) = postHighPairs (Just ph)
|
||||
highlightSettingsPairs (Just (FastVector fvh)) = fastVectorHighPairs (Just fvh)
|
||||
|
||||
|
||||
plainHighPairs :: Maybe PlainHighlight -> [Pair]
|
||||
plainHighPairs Nothing = []
|
||||
plainHighPairs (Just (PlainHighlight plCom plNonPost)) =
|
||||
[ "type" .= String "plain"]
|
||||
++ commonHighlightPairs plCom
|
||||
++ nonPostingsToPairs plNonPost
|
||||
|
||||
postHighPairs :: Maybe PostingsHighlight -> [Pair]
|
||||
postHighPairs Nothing = []
|
||||
postHighPairs (Just (PostingsHighlight pCom)) =
|
||||
("type" .= String "postings")
|
||||
: commonHighlightPairs pCom
|
||||
|
||||
fastVectorHighPairs :: Maybe FastVectorHighlight -> [Pair]
|
||||
fastVectorHighPairs Nothing = []
|
||||
fastVectorHighPairs
|
||||
(Just
|
||||
(FastVectorHighlight fvCom fvNonPostSettings' fvBoundChars
|
||||
fvBoundMaxScan fvFragOff fvMatchedFields
|
||||
fvPhraseLim)) =
|
||||
[ "type" .= String "fvh"
|
||||
, "boundary_chars" .= fvBoundChars
|
||||
, "boundary_max_scan" .= fvBoundMaxScan
|
||||
, "fragment_offset" .= fvFragOff
|
||||
, "matched_fields" .= fvMatchedFields
|
||||
, "phraseLimit" .= fvPhraseLim]
|
||||
++ commonHighlightPairs fvCom
|
||||
++ nonPostingsToPairs fvNonPostSettings'
|
||||
|
||||
commonHighlightPairs :: Maybe CommonHighlight -> [Pair]
|
||||
commonHighlightPairs Nothing = []
|
||||
commonHighlightPairs (Just (CommonHighlight chScore chForceSource
|
||||
chTag chEncoder chNoMatchSize
|
||||
chHighlightQuery chRequireFieldMatch)) =
|
||||
[ "order" .= chScore
|
||||
, "force_source" .= chForceSource
|
||||
, "encoder" .= chEncoder
|
||||
, "no_match_size" .= chNoMatchSize
|
||||
, "highlight_query" .= chHighlightQuery
|
||||
, "require_fieldMatch" .= chRequireFieldMatch
|
||||
]
|
||||
++ highlightTagToPairs chTag
|
||||
|
||||
|
||||
nonPostingsToPairs :: Maybe NonPostings -> [Pair]
|
||||
nonPostingsToPairs Nothing = []
|
||||
nonPostingsToPairs (Just (NonPostings npFragSize npNumOfFrags)) =
|
||||
[ "fragment_size" .= npFragSize
|
||||
, "number_of_fragments" .= npNumOfFrags
|
||||
]
|
||||
|
||||
highlightTagToPairs :: Maybe HighlightTag -> [Pair]
|
||||
highlightTagToPairs (Just (TagSchema _)) =
|
||||
[ "scheme" .= String "default"
|
||||
]
|
||||
highlightTagToPairs (Just (CustomTags (pre, post))) =
|
||||
[ "pre_tags" .= pre
|
||||
, "post_tags" .= post
|
||||
]
|
||||
highlightTagToPairs Nothing = []
|
||||
|
||||
265
src/Database/V5/Bloodhound/Internal/Suggest.hs
Normal file
265
src/Database/V5/Bloodhound/Internal/Suggest.hs
Normal file
@ -0,0 +1,265 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Database.V5.Bloodhound.Internal.Suggest where
|
||||
|
||||
import Bloodhound.Import
|
||||
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
|
||||
import Database.V5.Bloodhound.Internal.Newtypes
|
||||
import Database.V5.Bloodhound.Internal.Query (TemplateQueryInline(..), params)
|
||||
|
||||
data Suggest = Suggest
|
||||
{ suggestText :: Text
|
||||
, suggestName :: Text
|
||||
, suggestType :: SuggestType
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance ToJSON Suggest where
|
||||
toJSON Suggest{..} =
|
||||
object [ "text" .= suggestText
|
||||
, suggestName .= suggestType
|
||||
]
|
||||
|
||||
instance FromJSON Suggest where
|
||||
parseJSON (Object o) = do
|
||||
suggestText' <- o .: "text"
|
||||
let dropTextList =
|
||||
HM.toList
|
||||
$ HM.filterWithKey (\x _ -> x /= "text") o
|
||||
suggestName' <-
|
||||
case dropTextList of
|
||||
[(x, _)] -> return x
|
||||
_ -> fail "error parsing Suggest field name"
|
||||
suggestType' <- o .: suggestName'
|
||||
return $ Suggest suggestText' suggestName' suggestType'
|
||||
parseJSON x = typeMismatch "Suggest" x
|
||||
|
||||
data SuggestType =
|
||||
SuggestTypePhraseSuggester PhraseSuggester
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance ToJSON SuggestType where
|
||||
toJSON (SuggestTypePhraseSuggester x) =
|
||||
object [ "phrase" .= x ]
|
||||
|
||||
instance FromJSON SuggestType where
|
||||
parseJSON = withObject "SuggestType" parse
|
||||
where parse o = phraseSuggester `taggedWith` "phrase"
|
||||
where taggedWith parser k = parser =<< o .: k
|
||||
phraseSuggester = pure . SuggestTypePhraseSuggester
|
||||
|
||||
data PhraseSuggester = PhraseSuggester
|
||||
{ phraseSuggesterField :: FieldName
|
||||
, phraseSuggesterGramSize :: Maybe Int
|
||||
, phraseSuggesterRealWordErrorLikelihood :: Maybe Int
|
||||
, phraseSuggesterConfidence :: Maybe Int
|
||||
, phraseSuggesterMaxErrors :: Maybe Int
|
||||
, phraseSuggesterSeparator :: Maybe Text
|
||||
, phraseSuggesterSize :: Maybe Size
|
||||
, phraseSuggesterAnalyzer :: Maybe Analyzer
|
||||
, phraseSuggesterShardSize :: Maybe Int
|
||||
, phraseSuggesterHighlight :: Maybe PhraseSuggesterHighlighter
|
||||
, phraseSuggesterCollate :: Maybe PhraseSuggesterCollate
|
||||
, phraseSuggesterCandidateGenerators :: [DirectGenerators]
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance ToJSON PhraseSuggester where
|
||||
toJSON PhraseSuggester{..} =
|
||||
omitNulls [ "field" .= phraseSuggesterField
|
||||
, "gram_size" .= phraseSuggesterGramSize
|
||||
, "real_word_error_likelihood" .=
|
||||
phraseSuggesterRealWordErrorLikelihood
|
||||
, "confidence" .= phraseSuggesterConfidence
|
||||
, "max_errors" .= phraseSuggesterMaxErrors
|
||||
, "separator" .= phraseSuggesterSeparator
|
||||
, "size" .= phraseSuggesterSize
|
||||
, "analyzer" .= phraseSuggesterAnalyzer
|
||||
, "shard_size" .= phraseSuggesterShardSize
|
||||
, "highlight" .= phraseSuggesterHighlight
|
||||
, "collate" .= phraseSuggesterCollate
|
||||
, "direct_generator" .=
|
||||
phraseSuggesterCandidateGenerators
|
||||
]
|
||||
|
||||
instance FromJSON PhraseSuggester where
|
||||
parseJSON = withObject "PhraseSuggester" parse
|
||||
where parse o = PhraseSuggester
|
||||
<$> o .: "field"
|
||||
<*> o .:? "gram_size"
|
||||
<*> o .:? "real_word_error_likelihood"
|
||||
<*> o .:? "confidence"
|
||||
<*> o .:? "max_errors"
|
||||
<*> o .:? "separator"
|
||||
<*> o .:? "size"
|
||||
<*> o .:? "analyzer"
|
||||
<*> o .:? "shard_size"
|
||||
<*> o .:? "highlight"
|
||||
<*> o .:? "collate"
|
||||
<*> o .:? "direct_generator" .!= []
|
||||
|
||||
mkPhraseSuggester :: FieldName -> PhraseSuggester
|
||||
mkPhraseSuggester fName =
|
||||
PhraseSuggester fName Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
Nothing Nothing Nothing Nothing []
|
||||
|
||||
data PhraseSuggesterHighlighter =
|
||||
PhraseSuggesterHighlighter { phraseSuggesterHighlighterPreTag :: Text
|
||||
, phraseSuggesterHighlighterPostTag :: Text
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance ToJSON PhraseSuggesterHighlighter where
|
||||
toJSON PhraseSuggesterHighlighter{..} =
|
||||
object [ "pre_tag" .= phraseSuggesterHighlighterPreTag
|
||||
, "post_tag" .= phraseSuggesterHighlighterPostTag
|
||||
]
|
||||
|
||||
instance FromJSON PhraseSuggesterHighlighter where
|
||||
parseJSON = withObject "PhraseSuggesterHighlighter" parse
|
||||
where parse o = PhraseSuggesterHighlighter
|
||||
<$> o .: "pre_tag"
|
||||
<*> o .: "post_tag"
|
||||
|
||||
data PhraseSuggesterCollate = PhraseSuggesterCollate
|
||||
{ phraseSuggesterCollateTemplateQuery :: TemplateQueryInline
|
||||
, phraseSuggesterCollatePrune :: Bool
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance ToJSON PhraseSuggesterCollate where
|
||||
toJSON PhraseSuggesterCollate{..} =
|
||||
object [ "query" .= object
|
||||
[ "inline" .= (inline phraseSuggesterCollateTemplateQuery)
|
||||
]
|
||||
, "params" .= (params phraseSuggesterCollateTemplateQuery)
|
||||
, "prune" .= phraseSuggesterCollatePrune
|
||||
]
|
||||
|
||||
instance FromJSON PhraseSuggesterCollate where
|
||||
parseJSON (Object o) = do
|
||||
query' <- o .: "query"
|
||||
inline' <- query' .: "inline"
|
||||
params' <- o .: "params"
|
||||
prune' <- o .:? "prune" .!= False
|
||||
return $ PhraseSuggesterCollate
|
||||
(TemplateQueryInline inline' params') prune'
|
||||
parseJSON x = typeMismatch "PhraseSuggesterCollate" x
|
||||
|
||||
data SuggestOptions =
|
||||
SuggestOptions { suggestOptionsText :: Text
|
||||
, suggestOptionsScore :: Double
|
||||
, suggestOptionsFreq :: Maybe Int
|
||||
, suggestOptionsHighlighted :: Maybe Text
|
||||
}
|
||||
deriving (Eq, Read, Show)
|
||||
|
||||
instance FromJSON SuggestOptions where
|
||||
parseJSON = withObject "SuggestOptions" parse
|
||||
where
|
||||
parse o = SuggestOptions
|
||||
<$> o .: "text"
|
||||
<*> o .: "score"
|
||||
<*> o .:? "freq"
|
||||
<*> o .:? "highlighted"
|
||||
|
||||
data SuggestResponse =
|
||||
SuggestResponse { suggestResponseText :: Text
|
||||
, suggestResponseOffset :: Int
|
||||
, suggestResponseLength :: Int
|
||||
, suggestResponseOptions :: [SuggestOptions]
|
||||
}
|
||||
deriving (Eq, Read, Show)
|
||||
|
||||
instance FromJSON SuggestResponse where
|
||||
parseJSON = withObject "SuggestResponse" parse
|
||||
where parse o = SuggestResponse
|
||||
<$> o .: "text"
|
||||
<*> o .: "offset"
|
||||
<*> o .: "length"
|
||||
<*> o .: "options"
|
||||
|
||||
data NamedSuggestionResponse = NamedSuggestionResponse
|
||||
{ nsrName :: Text
|
||||
, nsrResponses :: [SuggestResponse]
|
||||
} deriving (Eq, Read, Show)
|
||||
|
||||
instance FromJSON NamedSuggestionResponse where
|
||||
parseJSON (Object o) = do
|
||||
suggestionName' <- case HM.toList o of
|
||||
[(x, _)] -> return x
|
||||
_ -> fail "error parsing NamedSuggestionResponse name"
|
||||
suggestionResponses' <- o .: suggestionName'
|
||||
return $ NamedSuggestionResponse suggestionName' suggestionResponses'
|
||||
|
||||
parseJSON x = typeMismatch "NamedSuggestionResponse" x
|
||||
|
||||
data DirectGeneratorSuggestModeTypes = DirectGeneratorSuggestModeMissing
|
||||
| DirectGeneratorSuggestModePopular
|
||||
| DirectGeneratorSuggestModeAlways
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance ToJSON DirectGeneratorSuggestModeTypes where
|
||||
toJSON DirectGeneratorSuggestModeMissing = "missing"
|
||||
toJSON DirectGeneratorSuggestModePopular = "popular"
|
||||
toJSON DirectGeneratorSuggestModeAlways = "always"
|
||||
|
||||
instance FromJSON DirectGeneratorSuggestModeTypes where
|
||||
parseJSON = withText "DirectGeneratorSuggestModeTypes" parse
|
||||
where
|
||||
parse "missing" =
|
||||
pure DirectGeneratorSuggestModeMissing
|
||||
parse "popular" =
|
||||
pure DirectGeneratorSuggestModePopular
|
||||
parse "always" =
|
||||
pure DirectGeneratorSuggestModeAlways
|
||||
parse f =
|
||||
fail ("Unexpected DirectGeneratorSuggestModeTypes: " <> show f)
|
||||
|
||||
data DirectGenerators = DirectGenerators
|
||||
{ directGeneratorsField :: FieldName
|
||||
, directGeneratorsSize :: Maybe Int
|
||||
, directGeneratorSuggestMode :: DirectGeneratorSuggestModeTypes
|
||||
, directGeneratorMaxEdits :: Maybe Double
|
||||
, directGeneratorPrefixLength :: Maybe Int
|
||||
, directGeneratorMinWordLength :: Maybe Int
|
||||
, directGeneratorMaxInspections :: Maybe Int
|
||||
, directGeneratorMinDocFreq :: Maybe Double
|
||||
, directGeneratorMaxTermFreq :: Maybe Double
|
||||
, directGeneratorPreFilter :: Maybe Text
|
||||
, directGeneratorPostFilter :: Maybe Text
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance ToJSON DirectGenerators where
|
||||
toJSON DirectGenerators{..} =
|
||||
omitNulls [ "field" .= directGeneratorsField
|
||||
, "size" .= directGeneratorsSize
|
||||
, "suggest_mode" .= directGeneratorSuggestMode
|
||||
, "max_edits" .= directGeneratorMaxEdits
|
||||
, "prefix_length" .= directGeneratorPrefixLength
|
||||
, "min_word_length" .= directGeneratorMinWordLength
|
||||
, "max_inspections" .= directGeneratorMaxInspections
|
||||
, "min_doc_freq" .= directGeneratorMinDocFreq
|
||||
, "max_term_freq" .= directGeneratorMaxTermFreq
|
||||
, "pre_filter" .= directGeneratorPreFilter
|
||||
, "post_filter" .= directGeneratorPostFilter
|
||||
]
|
||||
|
||||
instance FromJSON DirectGenerators where
|
||||
parseJSON = withObject "DirectGenerators" parse
|
||||
where parse o = DirectGenerators
|
||||
<$> o .: "field"
|
||||
<*> o .:? "size"
|
||||
<*> o .: "suggest_mode"
|
||||
<*> o .:? "max_edits"
|
||||
<*> o .:? "prefix_length"
|
||||
<*> o .:? "min_word_length"
|
||||
<*> o .:? "max_inspections"
|
||||
<*> o .:? "min_doc_freq"
|
||||
<*> o .:? "max_term_freq"
|
||||
<*> o .:? "pre_filter"
|
||||
<*> o .:? "post_filter"
|
||||
|
||||
mkDirectGenerators :: FieldName -> DirectGenerators
|
||||
mkDirectGenerators fn = DirectGenerators fn Nothing DirectGeneratorSuggestModeMissing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
@ -414,9 +414,6 @@ module Database.V5.Bloodhound.Types
|
||||
|
||||
import Bloodhound.Import
|
||||
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.Map.Strict as M
|
||||
|
||||
import Database.V5.Bloodhound.Types.Class
|
||||
import Database.V5.Bloodhound.Internal.Analysis
|
||||
import Database.V5.Bloodhound.Internal.Aggregation
|
||||
@ -425,6 +422,7 @@ import Database.V5.Bloodhound.Internal.Highlight
|
||||
import Database.V5.Bloodhound.Internal.Newtypes
|
||||
import Database.V5.Bloodhound.Internal.Query
|
||||
import Database.V5.Bloodhound.Internal.Sort
|
||||
import Database.V5.Bloodhound.Internal.Suggest
|
||||
|
||||
{-| 'unpackId' is a silly convenience function that gets used once.
|
||||
-}
|
||||
@ -484,14 +482,32 @@ data Source =
|
||||
| SourceIncludeExclude Include Exclude
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance ToJSON Source where
|
||||
toJSON NoSource = toJSON False
|
||||
toJSON (SourcePatterns patterns) = toJSON patterns
|
||||
toJSON (SourceIncludeExclude incl excl) = object [ "includes" .= incl, "excludes" .= excl ]
|
||||
|
||||
data PatternOrPatterns = PopPattern Pattern
|
||||
| PopPatterns [Pattern] deriving (Eq, Read, Show)
|
||||
|
||||
instance ToJSON PatternOrPatterns where
|
||||
toJSON (PopPattern pattern) = toJSON pattern
|
||||
toJSON (PopPatterns patterns) = toJSON patterns
|
||||
|
||||
data Include = Include [Pattern] deriving (Eq, Read, Show)
|
||||
data Exclude = Exclude [Pattern] deriving (Eq, Read, Show)
|
||||
|
||||
instance ToJSON Include where
|
||||
toJSON (Include patterns) = toJSON patterns
|
||||
|
||||
instance ToJSON Exclude where
|
||||
toJSON (Exclude patterns) = toJSON patterns
|
||||
|
||||
newtype Pattern = Pattern Text deriving (Eq, Read, Show)
|
||||
|
||||
instance ToJSON Pattern where
|
||||
toJSON (Pattern pattern) = toJSON pattern
|
||||
|
||||
data SearchResult a =
|
||||
SearchResult { took :: Int
|
||||
, timedOut :: Bool
|
||||
@ -499,7 +515,8 @@ data SearchResult a =
|
||||
, searchHits :: SearchHits a
|
||||
, aggregations :: Maybe AggregationResults
|
||||
, scrollId :: Maybe ScrollId
|
||||
-- ^ Only one Suggestion request / response per Search is supported.
|
||||
-- ^ Only one Suggestion request / response per
|
||||
-- Search is supported.
|
||||
, suggest :: Maybe NamedSuggestionResponse
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
@ -518,514 +535,3 @@ instance (FromJSON a) => FromJSON (SearchResult a) where
|
||||
newtype ScrollId =
|
||||
ScrollId Text
|
||||
deriving (Eq, Show, Ord, ToJSON, FromJSON)
|
||||
|
||||
data SearchHits a =
|
||||
SearchHits { hitsTotal :: Int
|
||||
, maxScore :: Score
|
||||
, hits :: [Hit a] } deriving (Eq, Show)
|
||||
|
||||
|
||||
instance (FromJSON a) => FromJSON (SearchHits a) where
|
||||
parseJSON (Object v) = SearchHits <$>
|
||||
v .: "total" <*>
|
||||
v .: "max_score" <*>
|
||||
v .: "hits"
|
||||
parseJSON _ = empty
|
||||
|
||||
instance Semigroup (SearchHits a) where
|
||||
(SearchHits ta ma ha) <> (SearchHits tb mb hb) =
|
||||
SearchHits (ta + tb) (max ma mb) (ha <> hb)
|
||||
|
||||
instance Monoid (SearchHits a) where
|
||||
mempty = SearchHits 0 Nothing mempty
|
||||
mappend = (<>)
|
||||
|
||||
data Hit a =
|
||||
Hit { hitIndex :: IndexName
|
||||
, hitType :: MappingName
|
||||
, hitDocId :: DocId
|
||||
, hitScore :: Score
|
||||
, hitSource :: Maybe a
|
||||
, hitFields :: Maybe HitFields
|
||||
, hitHighlight :: Maybe HitHighlight } deriving (Eq, Show)
|
||||
|
||||
instance (FromJSON a) => FromJSON (Hit a) where
|
||||
parseJSON (Object v) = Hit <$>
|
||||
v .: "_index" <*>
|
||||
v .: "_type" <*>
|
||||
v .: "_id" <*>
|
||||
v .: "_score" <*>
|
||||
v .:? "_source" <*>
|
||||
v .:? "fields" <*>
|
||||
v .:? "highlight"
|
||||
parseJSON _ = empty
|
||||
|
||||
data MissingResult = MissingResult
|
||||
{ missingDocCount :: Int
|
||||
} deriving (Show)
|
||||
|
||||
instance FromJSON MissingResult where
|
||||
parseJSON = withObject "MissingResult" parse
|
||||
where parse v = MissingResult <$> v .: "doc_count"
|
||||
|
||||
data TopHitResult a = TopHitResult
|
||||
{ tarHits :: (SearchHits a)
|
||||
} deriving Show
|
||||
|
||||
instance (FromJSON a) => FromJSON (TopHitResult a) where
|
||||
parseJSON (Object v) = TopHitResult <$>
|
||||
v .: "hits"
|
||||
parseJSON _ = fail "Failure in FromJSON (TopHitResult a)"
|
||||
|
||||
data TermsResult = TermsResult
|
||||
{ termKey :: BucketValue
|
||||
, termsDocCount :: Int
|
||||
, termsAggs :: Maybe AggregationResults
|
||||
} deriving (Read, Show)
|
||||
|
||||
instance FromJSON TermsResult where
|
||||
parseJSON (Object v) = TermsResult <$>
|
||||
v .: "key" <*>
|
||||
v .: "doc_count" <*>
|
||||
(pure $ getNamedSubAgg v ["key", "doc_count"])
|
||||
parseJSON _ = mempty
|
||||
|
||||
instance BucketAggregation TermsResult where
|
||||
key = termKey
|
||||
docCount = termsDocCount
|
||||
aggs = termsAggs
|
||||
|
||||
data DateHistogramResult = DateHistogramResult
|
||||
{ dateKey :: Int
|
||||
, dateKeyStr :: Maybe Text
|
||||
, dateDocCount :: Int
|
||||
, dateHistogramAggs :: Maybe AggregationResults
|
||||
} deriving (Show)
|
||||
|
||||
instance FromJSON DateHistogramResult where
|
||||
parseJSON (Object v) = DateHistogramResult <$>
|
||||
v .: "key" <*>
|
||||
v .:? "key_as_string" <*>
|
||||
v .: "doc_count" <*>
|
||||
(pure $ getNamedSubAgg v [ "key"
|
||||
, "doc_count"
|
||||
, "key_as_string"
|
||||
]
|
||||
)
|
||||
parseJSON _ = mempty
|
||||
|
||||
instance BucketAggregation DateHistogramResult where
|
||||
key = TextValue . showText . dateKey
|
||||
docCount = dateDocCount
|
||||
aggs = dateHistogramAggs
|
||||
|
||||
data DateRangeResult = DateRangeResult
|
||||
{ dateRangeKey :: Text
|
||||
, dateRangeFrom :: Maybe UTCTime
|
||||
, dateRangeFromAsString :: Maybe Text
|
||||
, dateRangeTo :: Maybe UTCTime
|
||||
, dateRangeToAsString :: Maybe Text
|
||||
, dateRangeDocCount :: Int
|
||||
, dateRangeAggs :: Maybe AggregationResults
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance FromJSON DateRangeResult where
|
||||
parseJSON = withObject "DateRangeResult" parse
|
||||
where parse v = DateRangeResult <$>
|
||||
v .: "key" <*>
|
||||
(fmap posixMS <$> v .:? "from") <*>
|
||||
v .:? "from_as_string" <*>
|
||||
(fmap posixMS <$> v .:? "to") <*>
|
||||
v .:? "to_as_string" <*>
|
||||
v .: "doc_count" <*>
|
||||
(pure $ getNamedSubAgg v [ "key"
|
||||
, "from"
|
||||
, "from_as_string"
|
||||
, "to"
|
||||
, "to_as_string"
|
||||
, "doc_count"
|
||||
]
|
||||
)
|
||||
|
||||
instance BucketAggregation DateRangeResult where
|
||||
key = TextValue . dateRangeKey
|
||||
docCount = dateRangeDocCount
|
||||
aggs = dateRangeAggs
|
||||
|
||||
toTerms :: Text -> AggregationResults -> Maybe (Bucket TermsResult)
|
||||
toTerms = toAggResult
|
||||
|
||||
toDateHistogram :: Text -> AggregationResults -> Maybe (Bucket DateHistogramResult)
|
||||
toDateHistogram = toAggResult
|
||||
|
||||
toMissing :: Text -> AggregationResults -> Maybe MissingResult
|
||||
toMissing = toAggResult
|
||||
|
||||
toTopHits :: (FromJSON a) => Text -> AggregationResults -> Maybe (TopHitResult a)
|
||||
toTopHits = toAggResult
|
||||
|
||||
toAggResult :: (FromJSON a) => Text -> AggregationResults -> Maybe a
|
||||
toAggResult t a = M.lookup t a >>= deserialize
|
||||
where deserialize = parseMaybe parseJSON
|
||||
|
||||
-- Try to get an AggregationResults when we don't know the
|
||||
-- field name. We filter out the known keys to try to minimize the noise.
|
||||
getNamedSubAgg :: Object -> [Text] -> Maybe AggregationResults
|
||||
getNamedSubAgg o knownKeys = maggRes
|
||||
where unknownKeys = HM.filterWithKey (\k _ -> k `notElem` knownKeys) o
|
||||
maggRes
|
||||
| HM.null unknownKeys = Nothing
|
||||
| otherwise = Just . M.fromList $ HM.toList unknownKeys
|
||||
|
||||
instance ToJSON Source where
|
||||
toJSON NoSource = toJSON False
|
||||
toJSON (SourcePatterns patterns) = toJSON patterns
|
||||
toJSON (SourceIncludeExclude incl excl) = object [ "includes" .= incl, "excludes" .= excl ]
|
||||
|
||||
instance ToJSON PatternOrPatterns where
|
||||
toJSON (PopPattern pattern) = toJSON pattern
|
||||
toJSON (PopPatterns patterns) = toJSON patterns
|
||||
|
||||
instance ToJSON Include where
|
||||
toJSON (Include patterns) = toJSON patterns
|
||||
|
||||
instance ToJSON Exclude where
|
||||
toJSON (Exclude patterns) = toJSON patterns
|
||||
|
||||
instance ToJSON Pattern where
|
||||
toJSON (Pattern pattern) = toJSON pattern
|
||||
|
||||
|
||||
instance ToJSON FieldHighlight where
|
||||
toJSON (FieldHighlight (FieldName fName) (Just fSettings)) =
|
||||
object [ fName .= fSettings ]
|
||||
toJSON (FieldHighlight (FieldName fName) Nothing) =
|
||||
object [ fName .= emptyObject ]
|
||||
|
||||
instance ToJSON Highlights where
|
||||
toJSON (Highlights global fields) =
|
||||
omitNulls (("fields" .= fields)
|
||||
: highlightSettingsPairs global)
|
||||
|
||||
instance ToJSON HighlightSettings where
|
||||
toJSON hs = omitNulls (highlightSettingsPairs (Just hs))
|
||||
|
||||
highlightSettingsPairs :: Maybe HighlightSettings -> [Pair]
|
||||
highlightSettingsPairs Nothing = []
|
||||
highlightSettingsPairs (Just (Plain plh)) = plainHighPairs (Just plh)
|
||||
highlightSettingsPairs (Just (Postings ph)) = postHighPairs (Just ph)
|
||||
highlightSettingsPairs (Just (FastVector fvh)) = fastVectorHighPairs (Just fvh)
|
||||
|
||||
|
||||
plainHighPairs :: Maybe PlainHighlight -> [Pair]
|
||||
plainHighPairs Nothing = []
|
||||
plainHighPairs (Just (PlainHighlight plCom plNonPost)) =
|
||||
[ "type" .= String "plain"]
|
||||
++ commonHighlightPairs plCom
|
||||
++ nonPostingsToPairs plNonPost
|
||||
|
||||
postHighPairs :: Maybe PostingsHighlight -> [Pair]
|
||||
postHighPairs Nothing = []
|
||||
postHighPairs (Just (PostingsHighlight pCom)) =
|
||||
("type" .= String "postings")
|
||||
: commonHighlightPairs pCom
|
||||
|
||||
fastVectorHighPairs :: Maybe FastVectorHighlight -> [Pair]
|
||||
fastVectorHighPairs Nothing = []
|
||||
fastVectorHighPairs (Just
|
||||
(FastVectorHighlight fvCom fvNonPostSettings fvBoundChars
|
||||
fvBoundMaxScan fvFragOff fvMatchedFields
|
||||
fvPhraseLim)) =
|
||||
[ "type" .= String "fvh"
|
||||
, "boundary_chars" .= fvBoundChars
|
||||
, "boundary_max_scan" .= fvBoundMaxScan
|
||||
, "fragment_offset" .= fvFragOff
|
||||
, "matched_fields" .= fvMatchedFields
|
||||
, "phraseLimit" .= fvPhraseLim]
|
||||
++ commonHighlightPairs fvCom
|
||||
++ nonPostingsToPairs fvNonPostSettings
|
||||
|
||||
commonHighlightPairs :: Maybe CommonHighlight -> [Pair]
|
||||
commonHighlightPairs Nothing = []
|
||||
commonHighlightPairs (Just (CommonHighlight chScore chForceSource
|
||||
chTag chEncoder chNoMatchSize
|
||||
chHighlightQuery chRequireFieldMatch)) =
|
||||
[ "order" .= chScore
|
||||
, "force_source" .= chForceSource
|
||||
, "encoder" .= chEncoder
|
||||
, "no_match_size" .= chNoMatchSize
|
||||
, "highlight_query" .= chHighlightQuery
|
||||
, "require_fieldMatch" .= chRequireFieldMatch
|
||||
]
|
||||
++ highlightTagToPairs chTag
|
||||
|
||||
|
||||
nonPostingsToPairs :: Maybe NonPostings -> [Pair]
|
||||
nonPostingsToPairs Nothing = []
|
||||
nonPostingsToPairs (Just (NonPostings npFragSize npNumOfFrags)) =
|
||||
[ "fragment_size" .= npFragSize
|
||||
, "number_of_fragments" .= npNumOfFrags
|
||||
]
|
||||
|
||||
highlightTagToPairs :: Maybe HighlightTag -> [Pair]
|
||||
highlightTagToPairs (Just (TagSchema _)) =
|
||||
[ "scheme" .= String "default"
|
||||
]
|
||||
highlightTagToPairs (Just (CustomTags (pre, post))) =
|
||||
[ "pre_tags" .= pre
|
||||
, "post_tags" .= post
|
||||
]
|
||||
highlightTagToPairs Nothing = []
|
||||
|
||||
data Suggest = Suggest
|
||||
{ suggestText :: Text
|
||||
, suggestName :: Text
|
||||
, suggestType :: SuggestType
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance ToJSON Suggest where
|
||||
toJSON Suggest{..} =
|
||||
object [ "text" .= suggestText
|
||||
, suggestName .= suggestType
|
||||
]
|
||||
|
||||
instance FromJSON Suggest where
|
||||
parseJSON (Object o) = do
|
||||
suggestText' <- o .: "text"
|
||||
let dropTextList =
|
||||
HM.toList
|
||||
$ HM.filterWithKey (\x _ -> x /= "text") o
|
||||
suggestName' <-
|
||||
case dropTextList of
|
||||
[(x, _)] -> return x
|
||||
_ -> fail "error parsing Suggest field name"
|
||||
suggestType' <- o .: suggestName'
|
||||
return $ Suggest suggestText' suggestName' suggestType'
|
||||
parseJSON x = typeMismatch "Suggest" x
|
||||
|
||||
data SuggestType =
|
||||
SuggestTypePhraseSuggester PhraseSuggester
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance ToJSON SuggestType where
|
||||
toJSON (SuggestTypePhraseSuggester x) =
|
||||
object [ "phrase" .= x ]
|
||||
|
||||
instance FromJSON SuggestType where
|
||||
parseJSON = withObject "SuggestType" parse
|
||||
where parse o = phraseSuggester `taggedWith` "phrase"
|
||||
where taggedWith parser k = parser =<< o .: k
|
||||
phraseSuggester = pure . SuggestTypePhraseSuggester
|
||||
|
||||
data PhraseSuggester = PhraseSuggester
|
||||
{ phraseSuggesterField :: FieldName
|
||||
, phraseSuggesterGramSize :: Maybe Int
|
||||
, phraseSuggesterRealWordErrorLikelihood :: Maybe Int
|
||||
, phraseSuggesterConfidence :: Maybe Int
|
||||
, phraseSuggesterMaxErrors :: Maybe Int
|
||||
, phraseSuggesterSeparator :: Maybe Text
|
||||
, phraseSuggesterSize :: Maybe Size
|
||||
, phraseSuggesterAnalyzer :: Maybe Analyzer
|
||||
, phraseSuggesterShardSize :: Maybe Int
|
||||
, phraseSuggesterHighlight :: Maybe PhraseSuggesterHighlighter
|
||||
, phraseSuggesterCollate :: Maybe PhraseSuggesterCollate
|
||||
, phraseSuggesterCandidateGenerators :: [DirectGenerators]
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance ToJSON PhraseSuggester where
|
||||
toJSON PhraseSuggester{..} =
|
||||
omitNulls [ "field" .= phraseSuggesterField
|
||||
, "gram_size" .= phraseSuggesterGramSize
|
||||
, "real_word_error_likelihood" .=
|
||||
phraseSuggesterRealWordErrorLikelihood
|
||||
, "confidence" .= phraseSuggesterConfidence
|
||||
, "max_errors" .= phraseSuggesterMaxErrors
|
||||
, "separator" .= phraseSuggesterSeparator
|
||||
, "size" .= phraseSuggesterSize
|
||||
, "analyzer" .= phraseSuggesterAnalyzer
|
||||
, "shard_size" .= phraseSuggesterShardSize
|
||||
, "highlight" .= phraseSuggesterHighlight
|
||||
, "collate" .= phraseSuggesterCollate
|
||||
, "direct_generator" .=
|
||||
phraseSuggesterCandidateGenerators
|
||||
]
|
||||
|
||||
instance FromJSON PhraseSuggester where
|
||||
parseJSON = withObject "PhraseSuggester" parse
|
||||
where parse o = PhraseSuggester
|
||||
<$> o .: "field"
|
||||
<*> o .:? "gram_size"
|
||||
<*> o .:? "real_word_error_likelihood"
|
||||
<*> o .:? "confidence"
|
||||
<*> o .:? "max_errors"
|
||||
<*> o .:? "separator"
|
||||
<*> o .:? "size"
|
||||
<*> o .:? "analyzer"
|
||||
<*> o .:? "shard_size"
|
||||
<*> o .:? "highlight"
|
||||
<*> o .:? "collate"
|
||||
<*> o .:? "direct_generator" .!= []
|
||||
|
||||
mkPhraseSuggester :: FieldName -> PhraseSuggester
|
||||
mkPhraseSuggester fName =
|
||||
PhraseSuggester fName Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
Nothing Nothing Nothing Nothing []
|
||||
|
||||
data PhraseSuggesterHighlighter =
|
||||
PhraseSuggesterHighlighter { phraseSuggesterHighlighterPreTag :: Text
|
||||
, phraseSuggesterHighlighterPostTag :: Text
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance ToJSON PhraseSuggesterHighlighter where
|
||||
toJSON PhraseSuggesterHighlighter{..} =
|
||||
object [ "pre_tag" .= phraseSuggesterHighlighterPreTag
|
||||
, "post_tag" .= phraseSuggesterHighlighterPostTag
|
||||
]
|
||||
|
||||
instance FromJSON PhraseSuggesterHighlighter where
|
||||
parseJSON = withObject "PhraseSuggesterHighlighter" parse
|
||||
where parse o = PhraseSuggesterHighlighter
|
||||
<$> o .: "pre_tag"
|
||||
<*> o .: "post_tag"
|
||||
|
||||
data PhraseSuggesterCollate = PhraseSuggesterCollate
|
||||
{ phraseSuggesterCollateTemplateQuery :: TemplateQueryInline
|
||||
, phraseSuggesterCollatePrune :: Bool
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance ToJSON PhraseSuggesterCollate where
|
||||
toJSON PhraseSuggesterCollate{..} =
|
||||
object [ "query" .= object
|
||||
[ "inline" .= (inline phraseSuggesterCollateTemplateQuery)
|
||||
]
|
||||
, "params" .= (params phraseSuggesterCollateTemplateQuery)
|
||||
, "prune" .= phraseSuggesterCollatePrune
|
||||
]
|
||||
|
||||
instance FromJSON PhraseSuggesterCollate where
|
||||
parseJSON (Object o) = do
|
||||
query' <- o .: "query"
|
||||
inline' <- query' .: "inline"
|
||||
params' <- o .: "params"
|
||||
prune' <- o .:? "prune" .!= False
|
||||
return $ PhraseSuggesterCollate
|
||||
(TemplateQueryInline inline' params') prune'
|
||||
parseJSON x = typeMismatch "PhraseSuggesterCollate" x
|
||||
|
||||
data SuggestOptions =
|
||||
SuggestOptions { suggestOptionsText :: Text
|
||||
, suggestOptionsScore :: Double
|
||||
, suggestOptionsFreq :: Maybe Int
|
||||
, suggestOptionsHighlighted :: Maybe Text
|
||||
}
|
||||
deriving (Eq, Read, Show)
|
||||
|
||||
instance FromJSON SuggestOptions where
|
||||
parseJSON = withObject "SuggestOptions" parse
|
||||
where
|
||||
parse o = SuggestOptions
|
||||
<$> o .: "text"
|
||||
<*> o .: "score"
|
||||
<*> o .:? "freq"
|
||||
<*> o .:? "highlighted"
|
||||
|
||||
data SuggestResponse =
|
||||
SuggestResponse { suggestResponseText :: Text
|
||||
, suggestResponseOffset :: Int
|
||||
, suggestResponseLength :: Int
|
||||
, suggestResponseOptions :: [SuggestOptions]
|
||||
}
|
||||
deriving (Eq, Read, Show)
|
||||
|
||||
instance FromJSON SuggestResponse where
|
||||
parseJSON = withObject "SuggestResponse" parse
|
||||
where parse o = SuggestResponse
|
||||
<$> o .: "text"
|
||||
<*> o .: "offset"
|
||||
<*> o .: "length"
|
||||
<*> o .: "options"
|
||||
|
||||
data NamedSuggestionResponse = NamedSuggestionResponse
|
||||
{ nsrName :: Text
|
||||
, nsrResponses :: [SuggestResponse]
|
||||
} deriving (Eq, Read, Show)
|
||||
|
||||
instance FromJSON NamedSuggestionResponse where
|
||||
parseJSON (Object o) = do
|
||||
suggestionName' <- case HM.toList o of
|
||||
[(x, _)] -> return x
|
||||
_ -> fail "error parsing NamedSuggestionResponse name"
|
||||
suggestionResponses' <- o .: suggestionName'
|
||||
return $ NamedSuggestionResponse suggestionName' suggestionResponses'
|
||||
|
||||
parseJSON x = typeMismatch "NamedSuggestionResponse" x
|
||||
|
||||
data DirectGeneratorSuggestModeTypes = DirectGeneratorSuggestModeMissing
|
||||
| DirectGeneratorSuggestModePopular
|
||||
| DirectGeneratorSuggestModeAlways
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance ToJSON DirectGeneratorSuggestModeTypes where
|
||||
toJSON DirectGeneratorSuggestModeMissing = "missing"
|
||||
toJSON DirectGeneratorSuggestModePopular = "popular"
|
||||
toJSON DirectGeneratorSuggestModeAlways = "always"
|
||||
|
||||
instance FromJSON DirectGeneratorSuggestModeTypes where
|
||||
parseJSON = withText "DirectGeneratorSuggestModeTypes" parse
|
||||
where
|
||||
parse "missing" =
|
||||
pure DirectGeneratorSuggestModeMissing
|
||||
parse "popular" =
|
||||
pure DirectGeneratorSuggestModePopular
|
||||
parse "always" =
|
||||
pure DirectGeneratorSuggestModeAlways
|
||||
parse f =
|
||||
fail ("Unexpected DirectGeneratorSuggestModeTypes: " <> show f)
|
||||
|
||||
data DirectGenerators = DirectGenerators
|
||||
{ directGeneratorsField :: FieldName
|
||||
, directGeneratorsSize :: Maybe Int
|
||||
, directGeneratorSuggestMode :: DirectGeneratorSuggestModeTypes
|
||||
, directGeneratorMaxEdits :: Maybe Double
|
||||
, directGeneratorPrefixLength :: Maybe Int
|
||||
, directGeneratorMinWordLength :: Maybe Int
|
||||
, directGeneratorMaxInspections :: Maybe Int
|
||||
, directGeneratorMinDocFreq :: Maybe Double
|
||||
, directGeneratorMaxTermFreq :: Maybe Double
|
||||
, directGeneratorPreFilter :: Maybe Text
|
||||
, directGeneratorPostFilter :: Maybe Text
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance ToJSON DirectGenerators where
|
||||
toJSON DirectGenerators{..} =
|
||||
omitNulls [ "field" .= directGeneratorsField
|
||||
, "size" .= directGeneratorsSize
|
||||
, "suggest_mode" .= directGeneratorSuggestMode
|
||||
, "max_edits" .= directGeneratorMaxEdits
|
||||
, "prefix_length" .= directGeneratorPrefixLength
|
||||
, "min_word_length" .= directGeneratorMinWordLength
|
||||
, "max_inspections" .= directGeneratorMaxInspections
|
||||
, "min_doc_freq" .= directGeneratorMinDocFreq
|
||||
, "max_term_freq" .= directGeneratorMaxTermFreq
|
||||
, "pre_filter" .= directGeneratorPreFilter
|
||||
, "post_filter" .= directGeneratorPostFilter
|
||||
]
|
||||
|
||||
instance FromJSON DirectGenerators where
|
||||
parseJSON = withObject "DirectGenerators" parse
|
||||
where parse o = DirectGenerators
|
||||
<$> o .: "field"
|
||||
<*> o .:? "size"
|
||||
<*> o .: "suggest_mode"
|
||||
<*> o .:? "max_edits"
|
||||
<*> o .:? "prefix_length"
|
||||
<*> o .:? "min_word_length"
|
||||
<*> o .:? "max_inspections"
|
||||
<*> o .:? "min_doc_freq"
|
||||
<*> o .:? "max_term_freq"
|
||||
<*> o .:? "pre_filter"
|
||||
<*> o .:? "post_filter"
|
||||
|
||||
mkDirectGenerators :: FieldName -> DirectGenerators
|
||||
mkDirectGenerators fn = DirectGenerators fn Nothing DirectGeneratorSuggestModeMissing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
|
||||
Loading…
Reference in New Issue
Block a user